A Compendium of Clean Graphs in R
Version 2.0
Eric-Jan Wagenmakers and Quentin F. Gronau
- 1 Preface
- 2 Introduction
- 3 Correlations
- 4 Histograms
- 5 Line Plots
- 6 Bar Plots
- 7 Densities
- 8 Functions
- 9 Time Series
- 10 Multiple Panels
- 11 Graphs from JASP
- 12 Miscellaneous
- 12.1 Funnel Plot
- 12.2 Network Graph
- 12.3 Questionnaire Graph
- 12.4 Heatmap with Contour Lines
- 12.5 Nonparametric Bayes
- 12.6 Confidence Band Plot
- 12.7 Many Intervals in One Plot
- 12.8 Many Bayes Factors in One Plot
- 12.9 Prior and Posterior Distributions with Frills
- 12.10 Heatmap Updating
- 12.11 Meta-Analytic Forest Plot
- 12.12 Many Bayes Factors with Zoom
- 12.13 Reproducibility Project: The Correlation Graph
- 12.14 Reproducibility Project: The Layered-Violin Graph
- 13 References
=======================================================================================
1 Preface
When done right, graphs can be appealing, informative, and of considerable value to an academic article. Unfortunately, researchers generally suck at making good graphs. We surmise that this is because researchers do not completely master their graphing software, and they are either too lazy or too busy to remedy the situation. Consequently, the produced graph is often a severe distortion of the ideal Platonian graph that the researcher had in mind initially.
This compendium facilitates the creation of good graphs by presenting a set of concrete examples, ranging from the trivial to the advanced. The graphs can all be reproduced and adjusted by copy-pasting code into the R console. A note for R fans: the majority of our plots have been created in base R, but you will encounter some examples in ggplot.
Almost every example in this compendium is driven by the same philosophy: A good graph is a simple graph, in the Einsteinian sense that a graph should be made as simple as possible, but not simpler.
We close with a request and a piece of advice. The request: if you create a clean graph in R that you believe is a candidate for inclusion in this compendium, please do not hesitate to contact us at EJ.Wagenmakers@gmail.com or quentingronau@web.de. Your contribution will be acknowledged explicitly, alongside the code you provided. The advice: when you create a clean graph in R, put it on Flickr (public license) before you sign away your copyright to a publisher. For an example, see Figure 1 from this paper.
This work has profited greatly from interactions with our colleagues, many of whom have contributed graphs of their own.
2 Introduction
Producing clean graphs can be a challenging task. First you have to consider what is the best way in which to convey the information: a line graph, a histogram, a multi-panel plot; such conceptual dilemma’s are not dealt with in this compendium, and instead we recommend the reader to the chapters on creating graphs in the excellent book by Briscoe (1996). Second, you have to use computer software to translate the conceptual graph to a publication-ready figure. This is the phase where this compendium may be useful, because it brings together R code for producing a set of clean, publication-ready figures. Hopefully this will make it easy to copy-paste and adjust the code to suit your own needs.
In our experience, many graphs can be dramatically improved by adhering to the following guidlines: (1) invest sufficient time and effort in the process; (2) omit needless graphical elements, that is, make every element count; (3) judge the relative impact of the graphical elements and ensure that they are in balance; (4) use large font sizes for all text; (5) deviate from the R default settings – with a little effort, you can do a lot better.
This compendium does not discuss figure headings. However, we will say that it is clearly desirable to have the main message of a figure be understood without being forced to read the main text. If possible, start your figure heading by stating what the figure is meant to demonstrate (i.e., its interpretation). For example, do not state “Popularity as a function of president height”; instead, state “Taller presidents are more popular”.
Finally, a note on color. Many graphs look better in color, but there are two complications. First, some academic journals do not publish manuscripts in color, at least not without charging a hefty price. Second, many readers and reviewers do not have a color printer. Below, some graphs have color, whereas others only use grey-scales. Of course this is one of the easiest things to adjust.
Based on this compendium, learning to create good graphs in R will be 80% copy-paste and 20% tinkering. Let’s go plot ourselves some graphs!
3 Correlations
Whenever a researcher reports a correlation, it is imperative to plot the data. Anscombe’s quartet (plotted below) is a famous demonstration of this fact.
3.1 The Electoral Advantage of Being Tall
This plot shows the relation between the height ratio of US presidents and the percentage of the popular vote. Note the large circles for the data, the thick line for the linear relation, and the large font size for the axis labels. Also, note that the line does not touch the y-axis (a subtlety that requires deviating from the default).
Show R-Code# Presidential data up to and including 2008; data from Stulp et al. 2013
# rm(list=ls())
# height of president divided by height of most successful opponent:
height.ratio <- c(0.924324324, 1.081871345, 1, 0.971098266, 1.029761905,
0.935135135, 0.994252874, 0.908163265, 1.045714286, 1.18404908,
1.115606936, 0.971910112, 0.97752809, 0.978609626, 1,
0.933333333, 1.071428571, 0.944444444, 0.944444444, 1.017142857,
1.011111111, 1.011235955, 1.011235955, 1.089285714, 0.988888889,
1.011111111, 1.032967033, 1.044444444, 1, 1.086705202,
1.011560694, 1.005617978, 1.005617978, 1.005494505, 1.072222222,
1.011111111, 0.983783784, 0.967213115, 1.04519774, 1.027777778,
1.086705202, 1, 1.005347594, 0.983783784, 0.943005181, 1.057142857)
# proportion popular vote for president vs most successful opponent
# NB can be lower than .5 because popolar vote does not decide election
pop.vote <- c(0.427780852, 0.56148981, 0.597141922, 0.581254292, 0.530344067,
0.507425996, 0.526679292, 0.536690951, 0.577825976, 0.573225387,
0.550410082, 0.559380032, 0.484823958, 0.500466176, 0.502934212,
0.49569636, 0.516904414, 0.522050547, 0.531494442, 0.60014892,
0.545079801, 0.604274986, 0.51635906, 0.63850958, 0.652184407,
0.587920412, 0.5914898, 0.624614752, 0.550040193, 0.537771958,
0.523673642, 0.554517134, 0.577511576, 0.500856251, 0.613444534,
0.504063153, 0.617883695, 0.51049949, 0.553073235, 0.59166415,
0.538982024, 0.53455133, 0.547304058, 0.497350649, 0.512424242,
0.536914796)
# cor.test(height.ratio,pop.vote)
library(plotrix) # package plotrix is needed for function "ablineclip""
# if the following line and the line containing "dev.off()" are executed, the plot will be saved as a png file in the current working directory
# png("Presidental.png", width = 18, height = 18, units = "cm", res = 800, pointsize = 10)
op <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5 , font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
plot(height.ratio, pop.vote, col = "black", pch = 21, bg = "grey", cex = 2,
xlim = c(.90,1.20), ylim = c(.40,.70), ylab = "", xlab = "", axes = FALSE)
axis(1)
axis(2)
reg1 <- lm(pop.vote ~ height.ratio)
ablineclip(reg1, lwd = 2,x1 = .9, x2 = 1.2)
par(las = 0)
mtext("Presidential Height Ratio", side = 1, line = 2.5, cex = 1.5)
mtext("Relative Support for President", side = 2, line = 3.7, cex = 1.5)
text(1.15, .65, "r = .39", cex = 1.5)
# dev.off()
# For comparison, consider the default plot:
# par(op) # reset to default "par" settings
# plot(height.ratio, pop.vote) #yuk!
4 Histograms
Histograms are relatively straightforward to create and to interpret. In fact, some people may even find them boring. Luckily, it is easy to increase the reader’s interest level by adding information to the plot. Below we illustrate various ways by which this may be accomplished.
4.1 Including “rug” Tick Marks
When in doubt, add tick marks that showcase the individual data points. This is particularly useful when the number of data points is small. The code below is courtesy of Helen Steingroever. Note that the rug tick marks are jittered.
Show R-Code# rm(list = ls())
# Data: Proportion of choices from the good decks as reported in 39 studies
good.choices <- c(.43, .47, .47, .48, .50, .52, .53, .53, .54, .54, .54, .54, .55, .55, .55, .56, .56, .57, .57, .57, .57, .58, .58, .58, .59, .59, .60, .62, .63, .63, .64, .64, .66, .66, .67, .67, .68, .70, .70)
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5 , font.lab = 2, cex.axis = 1.3, bty = "n", las=1)
hist(good.choices, main = "", xlab = "", ylab = " ", ylim = c(0, 13), xlim = c(.30, .80), axes = FALSE, col = "grey")
axis(1, seq(.30, .80, by = .1))
axis(2, seq(.00, 12, by = 2))
rug(jitter(good.choices))
mtext("Prop. Choices from Good Decks", side = 1, line = 2.5, cex = 1.5, font = 2)
mtext("Number of Studies", side = 2, line = 3, cex = 1.5, font = 2, las = 0)
4.2 Including a Density Estimator
In R, it is easy to include a nonparametric density estimator. This requires that freq = FALSE in the histogram comment. Courtesy of Helen Steingroever.
# rm(list = ls())
# Data: Proportion of choices from the good decks as reported in 39 studies
good.choices <- c(.43, .47, .47, .48, .50, .52, .53, .53, .54, .54, .54, .54, .55, .55, .55, .56, .56, .57, .57, .57, .57, .58, .58, .58, .59, .59, .60, .62, .63, .63, .64, .64, .66, .66, .67, .67, .68, .70, .70)
yhigh <- 8
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5 , font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
h <- hist(good.choices, freq = FALSE, main = "", xlab = "", ylab = " ", ylim = c(0, yhigh), xlim = c(.30, .80), axes = FALSE, col = "grey")
axis(1, seq(.30, .80, by = .1))
axis(2, labels = FALSE, lwd.ticks = 0)
rug(jitter(good.choices))
mtext("Prop. Choices from Good Decks", side = 1, line = 2.5, cex = 1.5, font = 2)
mtext("Density of Studies", side = 2, line = 1, cex = 1.5, font = 2, las = 0)
lines(density(good.choices), lwd = 2)
4.3 Including Numbers on Top
This example shows how to display the bar heights, using the function l_ply. Courtesy of Helen Steingroever and Quentin Gronau.
# rm(list = ls())
library(plyr) # needed for function 'l_ply'
# Data: Proportion of choices from the good decks as reported in 39 studies
good.choices <- c(0.43, 0.47, 0.47, 0.48, 0.5, 0.52, 0.53, 0.53, 0.54, 0.54,
0.54, 0.54, 0.55, 0.55, 0.55, 0.56, 0.56, 0.57, 0.57, 0.57, 0.57, 0.58, 0.58,
0.58, 0.59, 0.59, 0.6, 0.62, 0.63, 0.63, 0.64, 0.64, 0.66, 0.66, 0.67, 0.67,
0.68, 0.7, 0.7)
yhigh <- 8
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
h <- hist(good.choices, freq = FALSE, main = "", xlab = "", ylab = " ", ylim = c(0,
yhigh), xlim = c(0.3, 0.8), axes = FALSE, col = "grey")
l_ply(seq_along(h$density), function(x) text(h$mids[x], h$density[x] + 0.32,
round(h$density[x], 2), cex = 1.2))
axis(1, seq(0.3, 0.8, by = 0.1))
axis(2, labels = FALSE, lwd.ticks = 0)
rug(jitter(good.choices))
mtext("Prop. Choices from Good Decks", side = 1, line = 2.5, cex = 1.5, font = 2)
mtext("Density of Studies", side = 2, line = 1, cex = 1.5, font = 2, las = 0)
5 Line Plots
The line plot is one of the most standard plots. Nevertheless, many researchers fail to realize that line plots deserve love and attention too.
5.1 Regular Line Plot
This graph plots error bars with a user-defined function. More to the
point, the lines are thick, and they do not overlap with the symbols (type = "c"). Note that the legend is not needed; the legend text could simply have been positioned near the associated graphical elements.
plotsegraph <- function(loc, value, sterr, wiskwidth, color = "grey", linewidth = 2) {
w <- wiskwidth/2
segments(x0 = loc, x1 = loc, y0 = value - sterr, y1 = value + sterr, col = color,
lwd = linewidth)
segments(x0 = loc - w, x1 = loc + w, y0 = value + sterr, y1 = value + sterr,
col = color, lwd = linewidth) # upper whiskers
segments(x0 = loc - w, x1 = loc + w, y0 = value - sterr, y1 = value - sterr,
col = color, lwd = linewidth) # lower whiskers
}
RT.hf.sp <- 0.41
RT.lf.sp <- 0.43
RT.vlf.sp <- 0.425
se.RT.hf.sp <- 0.01
se.RT.lf.sp <- 0.015
se.RT.vlf.sp <- 0.02
RT.hf.ac <- 0.46
RT.lf.ac <- 0.51
RT.vlf.ac <- 0.52
se.RT.hf.ac <- 0.01
se.RT.lf.ac <- 0.015
se.RT.vlf.ac <- 0.02
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = "", xlab = " ", cex = 1.5,
ylim = c(0.3, 0.6), xlim = c(1, 4), lwd = 2, pch = 5, axes = F, main = " ")
axis(1, at = c(1.5, 2.5, 3.5), labels = c("HF", "LF", "VLF"))
mtext("Word Frequency", side = 1, line = 3, cex = 1.5, font = 2)
axis(2, pos = 1.2, )
par(las = 0)
mtext(expression(paste("Mean ", mu)), side = 2, line = 2, cex = 1.5, font = 2)
x <- c(1.5, 2.5, 3.5)
points(x, c(RT.hf.sp, RT.lf.sp, RT.vlf.sp), cex = 1.5, lwd = 2, pch = 19)
plot.errbars <- plotsegraph(x, c(RT.hf.sp, RT.lf.sp, RT.vlf.sp), c(se.RT.hf.sp,
se.RT.lf.sp, se.RT.vlf.sp), 0.1, color = "black") #0.1 = wiskwidth
lines(c(1.5, 2.5, 3.5), c(RT.hf.sp, RT.lf.sp, RT.vlf.sp), lwd = 2, type = "c")
points(x, c(RT.hf.ac, RT.lf.ac, RT.vlf.ac), cex = 1.5, lwd = 2, pch = 21)
plot.errbars <- plotsegraph(x, c(RT.hf.ac, RT.lf.ac, RT.vlf.ac), c(se.RT.hf.ac,
se.RT.lf.ac, se.RT.vlf.ac), 0.1, color = "black") #0.1 = wiskwidth
lines(c(1.5, 2.5, 3.5), c(RT.hf.ac, RT.lf.ac, RT.vlf.ac), lwd = 2, type = "c")
points(1.5, 0.6, pch = 21, lwd = 2, cex = 1.5)
text(1.7, 0.6, "Accuracy", cex = 1.2, font = 1, adj = 0)
points(1.5, 0.57, pch = 19, lwd = 2, cex = 1.5)
text(1.7, 0.57, "Speed", cex = 1.2, font = 1, adj = 0)
5.2 Box Plot
Similar to the above, this plot shows the distribuion of the data with a user-defined boxplot function.
Show R-Codeboxplot.ej <- function(y, xloc = 1, width.box = 0.25, lwd.box = 2, width.hor = 0.25,
lwd.hor = 2, range.wisk = 1.5, lwd.wisk = 2, pch.box = 16, cex.boxpoint = 2,
plot.outliers = FALSE, pch.out = 1, cex.out = 1, color = "black") {
# makes boxplot with dot as median and solid whisker Interquartile range =
# (.75 quantile) - (.25 quantile). Note: Wiskers are not always symmetrical;
# top wisker extends up to max(y) constrained by y <= (.75 quantile) +
# range.wisk*Interquartile range bottom whisker is determined by min(y)
# constrained by y >= (.25 quantile) - range.wisk*Interquartile range
Q <- quantile(y, c(0.25, 0.5, 0.75))
names(Q) <- NULL # gets rid of percentages
IQ.range <- Q[3] - Q[1]
low <- Q[1] - range.wisk * IQ.range
high <- Q[3] + range.wisk * IQ.range
index <- which((y >= low) & (y <= high))
wisk.low <- min(y[index])
wisk.high <- max(y[index])
outliers <- y[which((y < low) | (y > high))]
# plot median:
points(xloc, Q[2], pch = pch.box, cex = cex.boxpoint, col = color)
# plot box:
xleft <- xloc - width.box/2
xright <- xloc + width.box/2
ybottom <- Q[1]
ytop <- Q[3]
rect(xleft, ybottom, xright, ytop, lwd = lwd.box, border = color)
# plot whiskers:
segments(xloc, wisk.low, xloc, Q[1], lwd = lwd.wisk, col = color)
segments(xloc, Q[3], xloc, wisk.high, lwd = lwd.wisk, col = color)
# plot horizontal segments:
x0 <- xloc - width.hor/2
x1 <- xloc + width.hor/2
segments(x0, wisk.low, x1, wisk.low, lwd = lwd.hor, col = color)
segments(x0, wisk.high, x1, wisk.high, lwd = lwd.hor, col = color)
# plot outliers:
if (plot.outliers == TRUE) {
xloc.p <- rep(xloc, length(outliers))
points(xloc.p, outliers, pch = pch.out, cex = cex.out, col = color)
}
}
RT.hf.sp <- rnorm(1000, mean = 0.41, sd = 0.008)
RT.lf.sp <- rnorm(1000, mean = 0.43, sd = 0.01)
RT.vlf.sp <- rnorm(1000, mean = 0.425, sd = 0.012)
RT.hf.ac <- rnorm(1000, mean = 0.46, sd = 0.008)
RT.lf.ac <- rnorm(1000, mean = 0.51, sd = 0.01)
RT.vlf.ac <- rnorm(1000, mean = 0.52, sd = 0.012)
ps <- 1 # size of boxpoint
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = " ", xlab = " ", cex = 1.5,
ylim = c(0.3, 0.6), xlim = c(1, 4), lwd = 2, pch = 5, axes = FALSE, main = " ")
axis(1, at = c(1.5, 2.5, 3.5), labels = c("HF", "LF", "VLF"))
mtext("Word Frequency", side = 1, line = 3, cex = 1.5, font = 2)
axis(2, pos = 1.1)
par(las = 0)
mtext("Group Mean M", side = 2, line = 2.9, cex = 1.5, font = 2)
x <- c(1.5, 2.5, 3.5)
boxplot.ej(RT.hf.sp, xloc = 1.5, cex.boxpoint = ps)
boxplot.ej(RT.hf.ac, xloc = 1.5, cex.boxpoint = ps, color = "grey")
boxplot.ej(RT.lf.sp, xloc = 2.5, cex.boxpoint = ps)
boxplot.ej(RT.lf.ac, xloc = 2.5, cex.boxpoint = ps, color = "grey")
boxplot.ej(RT.vlf.sp, xloc = 3.5, cex.boxpoint = ps)
boxplot.ej(RT.vlf.ac, xloc = 3.5, cex.boxpoint = ps, color = "grey")
text(2.5, 0.35, "Speed", cex = 1.4, font = 1, adj = 0.5)
text(2.5, 0.57, "Accuracy", cex = 1.4, font = 1, col = "grey", adj = 0.5)
5.3 Violin Plot
By now this plot should look familiar. The distribution of the data
is now indicated with a violin plot instead of a box plot. Courtesy of
Henrik Singmann, who tweaked the results from the vioplot package. Warning: this a a lot of code.
RT.hf.sp <- rnorm(1000, mean = 0.41, sd = 0.008)
RT.lf.sp <- rnorm(1000, mean = 0.43, sd = 0.01)
RT.vlf.sp <- rnorm(1000, mean = 0.425, sd = 0.012)
RT.hf.ac <- rnorm(1000, mean = 0.46, sd = 0.008)
RT.lf.ac <- rnorm(1000, mean = 0.51, sd = 0.01)
RT.vlf.ac <- rnorm(1000, mean = 0.52, sd = 0.012)
library(sm)
# by Henrik Singmann customized violinplot function (singmann.org) the
# original violinplot function stems from the 'vioplot' package Copyright (c)
# 2004, Daniel Adler. All rights reserved. Redistribution and use in source
# and binary forms, with or without modification, are permitted provided that
# the following conditions are met: * Redistributions of source code must
# retain the above copyright notice, this list of conditions and the
# following disclaimer. * Redistributions in binary form must reproduce the
# above copyright notice, this list of conditions and the following
# disclaimer in the documentation and/or other materials provided with the
# distribution. * Neither the name of the University of Goettingen nor the
# names of its contributors may be used to endorse or promote products
# derived from this software without specific prior written permission. THIS
# SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
vioplot.singmann <- function(x, ..., range = 1.5, h = NULL, ylim = NULL, names = NULL,
horizontal = FALSE, col = NULL, border = "black", lty = 1, lwd = 1, rectCol = "black",
colMed = "white", pchMed = 19, at, add = FALSE, wex = 1, mark.outlier = TRUE,
pch.mean = 4, ids = NULL, drawRect = TRUE, yaxt = "s") {
# process multiple datas
datas <- list(x, ...)
n <- length(datas)
if (missing(at))
at <- 1:n
# pass 1 - calculate base range - estimate density setup parameters for
# density estimation
upper <- vector(mode = "numeric", length = n)
lower <- vector(mode = "numeric", length = n)
q1 <- vector(mode = "numeric", length = n)
q3 <- vector(mode = "numeric", length = n)
med <- vector(mode = "numeric", length = n)
base <- vector(mode = "list", length = n)
height <- vector(mode = "list", length = n)
outliers <- vector(mode = "list", length = n)
baserange <- c(Inf, -Inf)
# global args for sm.density function-call
args <- list(display = "none")
if (!(is.null(h)))
args <- c(args, h = h)
for (i in 1:n) {
data <- datas[[i]]
if (!is.null(ids))
names(data) <- ids
if (is.null(names(data)))
names(data) <- as.character(1:(length(data)))
# calculate plot parameters 1- and 3-quantile, median, IQR, upper- and
# lower-adjacent
data.min <- min(data)
data.max <- max(data)
q1[i] <- quantile(data, 0.25)
q3[i] <- quantile(data, 0.75)
med[i] <- median(data)
iqd <- q3[i] - q1[i]
upper[i] <- min(q3[i] + range * iqd, data.max)
lower[i] <- max(q1[i] - range * iqd, data.min)
# strategy: xmin = min(lower, data.min)) ymax = max(upper, data.max))
est.xlim <- c(min(lower[i], data.min), max(upper[i], data.max))
# estimate density curve
smout <- do.call("sm.density", c(list(data, xlim = est.xlim), args))
# calculate stretch factor the plots density heights is defined in range 0.0
# ... 0.5 we scale maximum estimated point to 0.4 per data
hscale <- 0.4/max(smout$estimate) * wex
# add density curve x,y pair to lists
base[[i]] <- smout$eval.points
height[[i]] <- smout$estimate * hscale
t <- range(base[[i]])
baserange[1] <- min(baserange[1], t[1])
baserange[2] <- max(baserange[2], t[2])
min.d <- boxplot.stats(data)[["stats"]][1]
max.d <- boxplot.stats(data)[["stats"]][5]
height[[i]] <- height[[i]][(base[[i]] > min.d) & (base[[i]] < max.d)]
height[[i]] <- c(height[[i]][1], height[[i]], height[[i]][length(height[[i]])])
base[[i]] <- base[[i]][(base[[i]] > min.d) & (base[[i]] < max.d)]
base[[i]] <- c(min.d, base[[i]], max.d)
outliers[[i]] <- list(data[(data < min.d) | (data > max.d)], names(data[(data <
min.d) | (data > max.d)]))
# calculate min,max base ranges
}
# pass 2 - plot graphics setup parameters for plot
if (!add) {
xlim <- if (n == 1)
at + c(-0.5, 0.5) else range(at) + min(diff(at))/2 * c(-1, 1)
if (is.null(ylim)) {
ylim <- baserange
}
}
if (is.null(names)) {
label <- 1:n
} else {
label <- names
}
boxwidth <- 0.05 * wex
# setup plot
if (!add)
plot.new()
if (!horizontal) {
if (!add) {
plot.window(xlim = xlim, ylim = ylim)
axis(2)
axis(1, at = at, label = label)
}
box()
for (i in 1:n) {
# plot left/right density curve
polygon(c(at[i] - height[[i]], rev(at[i] + height[[i]])), c(base[[i]],
rev(base[[i]])), col = col, border = border, lty = lty, lwd = lwd)
if (drawRect) {
# browser() plot IQR
boxplot(datas[[i]], at = at[i], add = TRUE, yaxt = yaxt, pars = list(boxwex = 0.6 *
wex, outpch = if (mark.outlier) "" else 1))
if ((length(outliers[[i]][[1]]) > 0) & mark.outlier)
text(rep(at[i], length(outliers[[i]][[1]])), outliers[[i]][[1]],
labels = outliers[[i]][[2]])
# lines( at[c( i, i)], c(lower[i], upper[i]) ,lwd=lwd, lty=lty) plot 50% KI
# box rect( at[i]-boxwidth/2, q1[i], at[i]+boxwidth/2, q3[i], col=rectCol)
# plot median point points( at[i], med[i], pch=pchMed, col=colMed )
}
points(at[i], mean(datas[[i]]), pch = pch.mean, cex = 1.3)
}
} else {
if (!add) {
plot.window(xlim = ylim, ylim = xlim)
axis(1)
axis(2, at = at, label = label)
}
box()
for (i in 1:n) {
# plot left/right density curve
polygon(c(base[[i]], rev(base[[i]])), c(at[i] - height[[i]], rev(at[i] +
height[[i]])), col = col, border = border, lty = lty, lwd = lwd)
if (drawRect) {
# plot IQR
boxplot(datas[[i]], yaxt = yaxt, at = at[i], add = TRUE, pars = list(boxwex = 0.8 *
wex, outpch = if (mark.outlier) "" else 1))
if ((length(outliers[[i]][[1]]) > 0) & mark.outlier)
text(rep(at[i], length(outliers[[i]][[1]])), outliers[[i]][[1]],
labels = outliers[[i]][[2]])
# lines( at[c( i, i)], c(lower[i], upper[i]) ,lwd=lwd, lty=lty)
}
points(at[i], mean(datas[[i]]), pch = pch.mean, cex = 1.3)
}
}
invisible(list(upper = upper, lower = lower, median = med, q1 = q1, q3 = q3))
}
# plot
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = " ", xlab = " ", cex = 1.5,
ylim = c(0.3, 0.6), xlim = c(1, 4), lwd = 2, pch = 5, axes = F, main = " ")
axis(1, at = c(1.5, 2.5, 3.5), labels = c("HF", "LF", "VLF"))
axis(2, pos = 1.1)
mtext("Word Frequency", side = 1, line = 3, cex = 1.5, font = 2)
par(las = 0)
mtext("Group Mean M", side = 2, line = 2.9, cex = 1.5, font = 2)
x <- c(1.5, 2.5, 3.5)
vioplot.singmann(RT.hf.sp, RT.lf.sp, RT.vlf.sp, add = TRUE, mark.outlier = FALSE,
at = c(1.5, 2.5, 3.5), wex = 0.4, yaxt = "n")
vioplot.singmann(RT.hf.ac, RT.lf.ac, RT.vlf.ac, add = TRUE, mark.outlier = FALSE,
at = c(1.5, 2.5, 3.5), wex = 0.4, col = "grey", border = "grey", rectCol = "grey",
colMed = "grey", yaxt = "n")
text(2.5, 0.35, "Speed", cex = 1.4, font = 1, adj = 0.5)
text(2.5, 0.58, "Accuracy", cex = 1.4, font = 1, col = "grey", adj = 0.5)
5.4 Combined Line and Bar Plot
In many psychological experiments, there are two dependent variables for each participant: mean response time (RT) and mean proportion of errors. This plot shows them both – RTs are on the left y-axis, and errors are on the right y-axis.
Show R-Code### Plot 1: RTs on first y-axis, errors on second y-axis
plotsebargraph = function(loc, value, sterr, wiskwidth, color = "grey", linewidth = 2) {
w = wiskwidth/2
segments(x0 = loc, x1 = loc, y0 = value, y1 = value + sterr, col = color,
lwd = linewidth)
segments(x0 = loc - w, x1 = loc + w, y0 = value + sterr, y1 = value + sterr,
col = color, lwd = linewidth) # upper whiskers
}
plotsegraph = function(loc, value, sterr, wiskwidth, color = "grey", linewidth = 2) {
w = wiskwidth/2
segments(x0 = loc, x1 = loc, y0 = value - sterr, y1 = value + sterr, col = color,
lwd = linewidth)
segments(x0 = loc - w, x1 = loc + w, y0 = value + sterr, y1 = value + sterr,
col = color, lwd = linewidth) # upper whiskers
segments(x0 = loc - w, x1 = loc + w, y0 = value - sterr, y1 = value - sterr,
col = color, lwd = linewidth) # lower whiskers
}
# =======================================================
# Data; order = Speed, neutral, accuracy
MRT <- c(429, 515, 555)
MRT.se <- c(25, 25, 30)
Er <- c(0.23, 0.14, 0.13)
Er.se <- c(0.022, 0.021, 0.021)
# ======================================================
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
# mpg = c(3, 1, 0) is default. first = axis labels!; middle = tick labels mar
# = c(5, 4, 4, 2) + 0.1 is default
digitsize <- 1.2
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = " Mean Response Time (ms.)",
xlab = " ", cex = 1.5, ylim = c(200, 800), xlim = c(1, 4), lwd = 2, pch = 5,
axes = F, main = " ")
axis(1, at = c(1.5, 2.5, 3.5), labels = c("Speed", "Neutral", "Accuracy"))
mtext("Cue", side = 1, line = 3, cex = 1.5, font = 2)
axis(2, at = c(300, 400, 500, 600, 700))
x = c(1.5, 2.5, 3.5)
points(x, MRT, cex = 1.5, lwd = 2, pch = 19)
plot.errbars = plotsegraph(x, MRT, MRT.se, 0.1, color = "black") #0.1 = wiskwidth
lines(c(1.5, 2.5, 3.5), MRT, lwd = 2, type = "c")
text(1.5, MRT[1] + 60, "429", adj = 0.5, cex = digitsize)
text(2.5, MRT[2] + 60, "515", adj = 0.5, cex = digitsize)
text(3.5, MRT[3] + 60, "555", adj = 0.5, cex = digitsize)
par(new = TRUE)
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = " ", xlab = " ", cex = 1.5,
ylim = c(0, 1), xlim = c(1, 4), lwd = 2, axes = FALSE, main = " ")
axis(4, at = c(0, 0.1, 0.2, 0.3, 0.4), las = 1)
grid::grid.text("Mean Proportion of Errors", 0.97, 0.5, rot = 270, gp = grid::gpar(cex = 1.5,
font = 2))
width <- 0.25
linewidth <- 2
x0 <- 1.5 - width
x1 <- 1.5 + width
y0 <- 0
y1 <- Er[1]
segments(x0, y0, x0, y1, lwd = linewidth)
segments(x0, y1, x1, y1, lwd = linewidth)
segments(x1, y1, x1, y0, lwd = linewidth)
segments(x1, y0, x0, y0, lwd = linewidth)
x0 <- 2.5 - width
x1 <- 2.5 + width
y0 <- 0
y1 <- Er[2]
segments(x0, y0, x0, y1, lwd = linewidth)
segments(x0, y1, x1, y1, lwd = linewidth)
segments(x1, y1, x1, y0, lwd = linewidth)
segments(x1, y0, x0, y0, lwd = linewidth)
x0 <- 3.5 - width
x1 <- 3.5 + width
y0 <- 0
y1 <- Er[3]
segments(x0, y0, x0, y1, lwd = linewidth)
segments(x0, y1, x1, y1, lwd = linewidth)
segments(x1, y1, x1, y0, lwd = linewidth)
segments(x1, y0, x0, y0, lwd = linewidth)
loc.errbars <- c(1.5, 2.5, 3.5)
plot.errbars <- plotsebargraph(loc.errbars, Er, Er.se, 0.2, color = "black") # 0.2 = wiskwidth
text(1.5, 0.9, "Behavioral Data", font = 2, cex = 2, pos = 4)
text(1.5, 0.05, "0.23", adj = 0.5, cex = digitsize)
text(2.5, 0.05, "0.14", adj = 0.5, cex = digitsize)
text(3.5, 0.05, "0.13", adj = 0.5, cex = digitsize)
6 Bar Plots
Like their histogram cousin, bar plots are intrinsically boring.
6.1 Including Error Bars
The title says it all. Note that the error bars are added with the l_ply function. Courtesy of Helen Steingroever and Quentin Gronau.
library(plyr)
mean.prop.sw <- c(0.7, 0.6, 0.67, 0.5, 0.45, 0.48, 0.41, 0.34, 0.5, 0.33)
sd.prop.sw <- c(0.3, 0.4, 0.2, 0.35, 0.28, 0.31, 0.29, 0.26, 0.21, 0.23)
N <- 100
b <- barplot(mean.prop.sw, las = 1, xlab = " ", ylab = " ", col = "grey", cex.lab = 1.7,
cex.main = 1.5, axes = FALSE, ylim = c(0, 1))
axis(1, c(0.8, 2, 3.2, 4.4, 5.6, 6.8, 8, 9.2, 10.4, 11.6), 1:10, cex.axis = 1.3)
axis(2, seq(0, 0.8, by = 0.2), cex.axis = 1.3, las = 1)
mtext("Block", side = 1, line = 2.5, cex = 1.5, font = 2)
mtext("Proportion of Switches", side = 2, line = 3, cex = 1.5, font = 2)
l_ply(seq_along(b), function(x) arrows(x0 = b[x], y0 = mean.prop.sw[x], x1 = b[x],
y1 = mean.prop.sw[x] + 1.96 * sd.prop.sw[x]/sqrt(N), code = 2, length = 0.1,
angle = 90, lwd = 1.5))
7 Densities
Densities are ubiquitous, particularly for those who have a predeliction for Bayesian inference. As for the histogram and the bar plot, it is generally a good idea to add more information to the bare-bones plot.
7.1 Standard
This is a relatively standard plot. Note the thickness of the lines and the font size for the axis labels.
Show R-Codeop <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
yhigh <- 1
xlow <- -3
xhigh <- 3
postmean <- 0.5
postsd <- 0.8
priormean <- 0
priorsd <- 1
plot(function(x) dnorm(x, mean = postmean, sd = postsd), xlow, xhigh, ylim = c(0,
yhigh), xlim = c(xlow, xhigh), lwd = 2, lty = 1, ylab = "", xlab = "", main = "Inference for Mu",
axes = FALSE)
lines(c(0, 0), c(0, 1.25), lwd = 2, col = "grey")
par(new = TRUE)
plot(function(x) dnorm(x, mean = priormean, sd = priorsd), xlow, xhigh, ylim = c(0,
yhigh), xlim = c(xlow, xhigh), lwd = 2, lty = 2, ylab = "", xlab = "", axes = FALSE)
axis(1)
axis(2)
par(las = 0)
mtext("Mu", side = 1, line = 2.5, cex = 1.5)
mtext("Density", side = 2, line = 3, cex = 1.8)
par(op)
7.2 With a Histogram on Top
This plot adds a histogram to the density plot, but without needlessly displaying the vertical histogram lines as well. In addition, the code defines the extent to which the lines are transparent, so that both the density and the histogram remain visible, and one does not completely block the other from view.
Show R-Codelibrary(polspline)
Gen.p.within = function(n.draws = 1000, n.data = 20, d = 0, s = 1) {
# Generates p-values from a within-subject (paired) t-test
p <- array(dim = n.draws)
for (i in 1:n.draws) {
# yes I know, vectorize is better
dat <- rnorm(n.data, mean = d, sd = s)
p[i] <- as.numeric(t.test(dat)$p.value)
}
return(p)
}
n.draws <- 20000
n.data <- 20
dfr <- n.data - 1
s <- 1
p.observed <- 0.045
t.observed <- qt(1 - (p.observed/2), dfr)
set.seed(1)
pvalues <- Gen.p.within(n.draws, n.data, d = s * t.observed/sqrt(n.data), s)
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
# Start with probit-transformed uniform distribution, that is, N(0,1):
y.high <- 1
x.high <- 4
x.low <- min(qnorm(pvalues))
curve(dnorm(x), from = -4, to = 4, add = FALSE, col = "black", lwd = 2, ylim = c(0,
y.high), xlim = c(x.low, x.high), ylab = "Density", xlab = " ", main = " ",
axes = FALSE)
axis(1)
axis(2)
mtext("Probit-transformed p Value", side = 1, line = 2.8, cex = 1.5)
greycolhist <- rgb(0, 0, 0, alpha = 0.7)
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 280, maxColorValue = 280)
# For transparent lines set, set 'alpha' between 0 (invisible) and 255
# (opaque)
lines(c(qnorm(p.observed), qnorm(p.observed)), c(0, y.high), lwd = 2, col = greycol) #at observed p
points(qnorm(p.observed), dnorm(qnorm(p.observed)), pch = 21, cex = 2, bg = "grey") # height under H0
height.H0 <- dnorm(qnorm(p.observed))
# Now for probit-transformed distribution of p-values under H1:
par(new = TRUE)
Nbreaks <- 20
small.y <- 0.05
y <- hist(qnorm(pvalues), Nbreaks, plot = FALSE)
plot(c(y$breaks, max(y$breaks)), c(0, y$density, 0), col = greycolhist, type = "S",
lwd = 2, lty = 1, ylim = c(0, y.high), xlim = c(x.low, x.high), xlab = " ",
ylab = "Density", main = " ")
pvalues.denspp <- logspline(qnorm(pvalues))
par(new = TRUE)
plot(pvalues.denspp, xlim = c(x.low, x.high), ylim = c(0, y.high), col = greycol,
lwd = 2)
height.H1 <- dlogspline(qnorm(p.observed), pvalues.denspp) # height under H1
points(qnorm(p.observed), height.H1, pch = 21, cex = 2, bg = "grey")
7.3 Including Text
This plot adds text to the plot. Although this is generally trivial, this particular example contains a mathematical symbol that is tricky to display properly (unless, of course, you know how it works).
Show R-CodeNormBF10 <- function(dat, mu = 0, m = 1, priordat = NULL, plot = F, xwide = 3) {
# dat ~ N(theta,1); theta ~ N(mu, 1/m); mu is prior mean, m is prior precision
if (is.null(priordat)) {
# no prior data
priormean <- mu
priorprec <- m
}
if (!is.null(priordat)) {
# prior data
n <- length(priordat)
priormean <- (m * mu + n * mean(priordat))/(m + n)
priorprec <- m + n
}
n <- length(dat)
posteriormean <- (priorprec * priormean + n * mean(dat))/(priorprec + n)
posteriorprec <- priorprec + n
prior.height <- dnorm(0, mean = priormean, sd = priorprec^(-0.5))
posterior.height <- dnorm(0, mean = posteriormean, sd = posteriorprec^(-0.5))
BF10 <- prior.height/posterior.height
if (plot == TRUE) {
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
yhigh <- 1.5
xlow <- -3
xhigh <- 3
plot(function(x) dnorm(x, mean = posteriormean, sd = posteriorprec^(-0.5)),
xlow, xhigh, ylim = c(0, yhigh), xlim = c(xlow, xhigh), lwd = 2,
lty = 1, ylab = "", xlab = "", axes = FALSE)
lines(c(0, 0), c(0, 1.25), lwd = 2, col = "grey")
par(new = TRUE)
plot(function(x) dnorm(x, mean = priormean, sd = priorprec^(-0.5)), xlow,
xhigh, ylim = c(0, yhigh), xlim = c(xlow, xhigh), lwd = 2, lty = 2,
ylab = "", xlab = "", axes = FALSE)
axis(1)
axis(2)
par(las = 0)
mtext("Mu", side = 1, line = 2.5, cex = 1.5)
mtext("Density", side = 2, line = 3, cex = 1.8)
# Show Savage-Dickey density ratio:
points(0, prior.height, cex = 2, pch = 21, bg = "grey")
points(0, posterior.height, cex = 2, pch = 21, bg = "grey")
}
invisible(BF10)
}
dat <- c(0, 1, -1)
# dat <- c(-1,1,0)
#### simultaneous #### 1/NormBF10(dat, plot = TRUE) #2 text(-3, 1.4,
#### expression(BF[0][1](y[1],y[2],y[3]) == 2), cex = 1.5, pos = 4)
##### y1 #### 1/NormBF10(dat = dat[1], plot = TRUE) #sqrt(2) text(-3, 1.4,
##### expression(BF[0][1](y[1]) == sqrt(2)), cex = 1.5, pos = 4)
##### y2, given y1 #### 1/NormBF10(dat = dat[2], plot = TRUE, priordat = dat[1]) #1.04
##### composite.expression <- expression(paste(BF[0][1], '(', y[2], ' | ', y[1],
##### ')' %~~% 1.04)) text(-3, 1.4, composite.expression, cex = 1.5, pos = 4)
##### y3, given y1 and y2 ####
BF01 <- 1/NormBF10(dat = dat[3], plot = TRUE, priordat = dat[1:2]) #1.36
composite.expression <- expression(paste(BF[0][1], "(", y[3], " | ", y[1], ",",
y[2], ")" %~~% 1.36))
text(-3, 1.4, composite.expression, cex = 1.5, pos = 4)
7.4 Another Example
This is another example, featuring a nice Greek letter. Seriously, what is important here is that the labels are positioned next to the associated graphical element. This approach is more direct than creating a legend, when the reader has to decode the legend first, keep the symbols in working memory, and then turn attention to the graph itself. Bottom line: only use legends when you have to. Even then, you may find that the legend box almost never fulfills a useful function, and can safely be omitted.
Show R-Codepar(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
yhigh <- 3
xi <- c(1, 0.5, 0.1)
plot(function(x) dbeta(x, xi[1], 1), 0, 1, ylim = c(0, yhigh), xlim = c(0, 1),
lwd = 2, lty = 1, xlab = " ", ylab = " ")
mtext("p value", 1, line = 2.5, cex = 1.5, font = 2)
mtext("Density", 2, line = 3, cex = 1.5, font = 2, las = 0)
par(new = TRUE)
plot(function(x) dbeta(x, xi[2], 1), 0, 1, ylim = c(0, yhigh), xlim = c(0, 1),
lwd = 2, lty = 2, xlab = " ", ylab = " ")
par(new = TRUE)
plot(function(x) dbeta(x, xi[3], 1), 0, 1, ylim = c(0, yhigh), xlim = c(0, 1),
lwd = 2, lty = 3, xlab = " ", ylab = " ")
cexsize <- 1.5
text(0.5, 1.15, expression(xi == 1(i.e., H[0])), cex = cexsize, pos = 4)
text(0.1, 1.6, expression(xi == 0.5), cex = cexsize, pos = 4)
text(0, 0.2, expression(xi == 0.1), cex = cexsize, pos = 4)
7.5 Highlighting Specific Areas
It is cool to be able to highlight specific parts of a density by
some color coding scheme. In this example, Ravi Selker shows how that
can be done (hint: it’s the polygon function).
x <- seq(0, 1, 0.001)
y <- dbeta(x, 2, 4)
y1 <- 0.25
y2 <- 0.62
par(cex.main = 2, mar = c(4, 2, 4, 2) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 2,
font.lab = 2, cex.axis = 2, bty = "n", las = 1, lwd = 3)
layout(matrix(c(1, 2), 1, 2))
########################################################## UNBIASED THRESHOLDS ######
plot(x, y, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "Unbiased Thresholds", bty = "n", yaxt = "n", xaxt = "n", xpd = FALSE)
polygon(c(x[which(x < 0.2)], 0.2, 0), c(y[which(x < 0.2)], 0, 0), col = "#E0E0E0",
xpd = FALSE)
polygon(c(x[which(x >= 0.2 & x < 0.4)], 0.4, 0.2), c(y[which(x >= 0.2 & x < 0.4)],
0, 0), col = "#C0C0C0", xpd = FALSE)
polygon(c(x[which(x >= 0.4 & x < 0.6)], 0.6, 0.4), c(y[which(x >= 0.4 & x < 0.6)],
0, 0), col = "#A0A0A0", xpd = FALSE)
polygon(c(x[which(x >= 0.6 & x < 0.8)], 0.8, 0.6), c(y[which(x >= 0.6 & x < 0.8)],
0, 0), col = "#808080", xpd = FALSE)
polygon(c(x[which(x >= 0.8)], 1, 0.8), c(y[which(x >= 0.8)], 0, 0), col = "#606060",
xpd = FALSE)
axis(1, c(0, 1), c("0", "1"), lwd = 0, cex = 2, pos = -0.09)
abline(v = 0)
abline(v = 1)
l <- seq(0, 3.2, 0.01)
x1 <- rep(0.2, length(l))
par(new = TRUE)
plot(x1, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "", bty = "n", yaxt = "n", xaxt = "n")
x2 <- rep(0.4, length(l))
par(new = TRUE)
plot(x2, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "", bty = "n", yaxt = "n", xaxt = "n")
x3 <- rep(0.6, length(l))
par(new = TRUE)
plot(x3, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "", bty = "n", yaxt = "n", xaxt = "n")
x4 <- rep(0.8, length(l))
par(new = TRUE)
plot(x4, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "", bty = "n", yaxt = "n", xaxt = "n")
text(0.2, 3.4, expression(gamma[1]), cex = 2)
text(0.4, 3.4, expression(gamma[2]), cex = 2)
text(0.6, 3.4, expression(gamma[3]), cex = 2)
text(0.8, 3.4, expression(gamma[4]), cex = 2)
text(0.1, 2.6, "1", cex = 2)
text(0.3, 2.6, "2", cex = 2)
text(0.5, 2.6, "3", cex = 2)
text(0.7, 2.6, "4", cex = 2)
text(0.9, 2.6, "5", cex = 2)
########################################################## BIASED THRESHOLDS ######
a <- 0.75 #scaling parameter
b <- 1.5 #shifting parameter
thr_1 <- (b * (0.2^a))/((1 - 0.2)^a + b * (0.2^a))
thr_2 <- (b * (0.4^a))/((1 - 0.4)^a + b * (0.4^a))
thr_3 <- (b * (0.6^a))/((1 - 0.6)^a + b * (0.6^a))
thr_4 <- (b * (0.8^a))/((1 - 0.8)^a + b * (0.8^a))
plot(x, y, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "Biased Thresholds", bty = "n", yaxt = "n", xaxt = "n", xpd = FALSE)
polygon(c(x[which(x < thr_1)], thr_1, 0), c(y[which(x < thr_1)], 0, 0), col = "#E0E0E0",
xpd = FALSE)
polygon(c(x[which(x >= thr_1 & x < thr_2)], thr_2, thr_1), c(y[which(x >= thr_1 &
x < thr_2)], 0, 0), col = "#C0C0C0", xpd = FALSE)
polygon(c(x[which(x >= thr_2 & x < thr_3)], thr_3, thr_2), c(y[which(x >= thr_2 &
x < thr_3)], 0, 0), col = "#A0A0A0", xpd = FALSE)
polygon(c(x[which(x >= thr_3 & x < thr_4)], thr_4, thr_3), c(y[which(x >= thr_3 &
x < thr_4)], 0, 0), col = "#808080", xpd = FALSE)
polygon(c(x[which(x >= thr_4)], 1, thr_4), c(y[which(x >= thr_4)], 0, 0), col = "#606060",
xpd = FALSE)
axis(1, c(0, 1), c("0", "1"), lwd = 0, cex = 2, pos = -0.09)
abline(v = 0)
abline(v = 1)
l <- seq(0, 3.2, 0.01)
x1 <- rep(thr_1, length(l))
par(new = TRUE)
plot(x1, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "", bty = "n", yaxt = "n", xaxt = "n")
x2 <- rep(thr_2, length(l))
par(new = TRUE)
plot(x2, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "", bty = "n", yaxt = "n", xaxt = "n")
x3 <- rep(thr_3, length(l))
par(new = TRUE)
plot(x3, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "", bty = "n", yaxt = "n", xaxt = "n")
x4 <- rep(thr_4, length(l))
par(new = TRUE)
plot(x4, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "",
main = "", bty = "n", yaxt = "n", xaxt = "n")
text(thr_1, 3.4, expression(delta[i1]), cex = 2)
text(thr_2, 3.4, expression(delta[i2]), cex = 2)
text(thr_3, 3.4, expression(delta[i3]), cex = 2)
text(thr_4, 3.4, expression(delta[i4]), cex = 2)
text(thr_1/2, 2.6, "1", cex = 2)
text((thr_1 + thr_2)/2, 2.6, "2", cex = 2)
text((thr_2 + thr_3)/2, 2.6, "3", cex = 2)
text((thr_3 + thr_4)/2, 2.6, "4", cex = 2)
text((thr_4 + 1)/2, 2.6, "5", cex = 2)
7.6 More Highlighting of Specific Areas
Mijke Rhemtulla also likes to highlight specific parts of a density. This is the first plot in a series, taken from one of Mijke’s stats courses.
Show R-Codexbar.therapy <- 92
s.therapy <- 8.5
xbar.placebo <- 85
s.placebo <- 9.1
n <- 15
xdiff <- xbar.therapy - xbar.placebo
sdiff <- sqrt((s.therapy^2 + s.placebo^2)/2) * sqrt(2/n)
sdiff <- sqrt(s.therapy^2 + s.placebo^2)/sqrt(n)
muH0 <- 0
muH1 <- 8
t0 <- (xdiff - muH0)/sdiff
# H0 distribution with p-value shaded:
par(cex.main = 1.5, mar = c(4, 4.5, 4.5, 1), mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
par(mar = c(4, 4.5, 4.5, 1))
x <- seq(-15, 15, by = 0.001)
y <- dt(x/sdiff, df = 28)
plot(x, y, type = "l", axes = FALSE, xlab = NA, ylab = NA, xlim = c(-15, 20),
lwd = 2)
axis(side = 1, at = seq(-15, 15, by = 5), pos = 0, lwd = 2)
axis(side = 1, at = 7, pos = 0, col = "red4", col.axis = "red4", lwd = 2)
# shade area to right of obtained test statistic:
t0 <- xdiff/sdiff
cord.x <- c(t0, seq(t0, 4, 0.001), 4) * sdiff
cord.y <- c(0, dt(seq(t0, 4, 0.001), df = 28), 0)
polygon(cord.x, cord.y, col = "grey")
cord.x <- c(-4, seq(-4, -t0, 0.001), -t0) * sdiff
cord.y <- c(0, dt(seq(-4, -t0, 0.001), df = 24), 0)
polygon(cord.x, cord.y, col = "grey")
# add lines and text:
abline(v = xdiff, col = "red4", lwd = 2)
text(-15, 0.25, expression(paste(H[0], " : ", mu[diff], " = 0", sep = "")), adj = 0,
cex = 1.8)
text(10, 0.08, paste("p = .04"), adj = 0, col = "red4", cex = 1.8)
lines(c(10, 8), c(0.05, 0.01), col = "red4", lwd = 2)
lines(c(10, -8), c(0.05, 0.01), col = "red4", lwd = 2)
mtext(expression(bar(x)[diff]), side = 1, line = 2, at = 6.5, adj = 0, col = "red4",
cex = 1.8)
7.7 Still More Highlighting
Part 2…
Show R-Codexbar.therapy <- 92
s.therapy <- 8.5
xbar.placebo <- 85
s.placebo <- 9.1
n <- 15
xdiff <- xbar.therapy - xbar.placebo
sdiff <- sqrt((s.therapy^2 + s.placebo^2)/2) * sqrt(2/n)
sdiff <- sqrt(s.therapy^2 + s.placebo^2)/sqrt(n)
muH0 <- 0
muH1 <- 8
t0 <- (xdiff - muH0)/sdiff
par(cex.main = 1.5, mar = c(4, 4.5, 4.5, 1), mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
x <- seq(-15, 30, by = 0.001)
y <- dt(x/sdiff, df = 28)
y3 <- dt((x - 9)/sdiff, df = 28)
plot(x, y, type = "l", axes = FALSE, xlab = NA, ylab = NA, xlim = c(-15, 30),
lwd = 2)
lines(x, y3, lwd = 2)
axis(side = 1, at = seq(-15, 30, by = 5), labels = seq(-15, 30, by = 5), cex.axis = 1.6,
lwd = 2)
axis(side = 1, at = 7, pos = 0, col = "red4", col.axis = "red4", lwd = 2, cex.axis = 1.6,
padj = 0.6)
# shade critical regions:
tcrit <- qt(0.975, df = 28)
cord.x <- c(tcrit, seq(tcrit, 4, 0.001), 4) * sdiff
cord.y <- c(0, dt(seq(tcrit, 4, 0.001), df = 28), 0)
polygon(cord.x, cord.y, col = "grey")
cord.x <- c(-4, seq(-4, -tcrit, 0.001), -tcrit) * sdiff
cord.y <- c(0, dt(seq(-4, -tcrit, 0.001), df = 24), 0)
polygon(cord.x, cord.y, col = "grey")
# shade type-II error region
xcrit <- tcrit * sdiff
cord.x <- c(-5, seq(-5, xcrit, 0.001), xcrit)
cord.y <- c(0, dt(((seq(-5, xcrit, 0.001) - 9)/sdiff), df = 28), 0)
polygon(cord.x, cord.y, col = "grey90")
# add lines and text:
abline(v = xdiff, col = "red4", lwd = 2)
text(-16.3, 0.3, expression(paste(H[0], " : ", mu[diff], " = 0", sep = "")),
adj = 0, cex = 1.8)
text(13, 0.3, expression(paste(H[1], " : ", mu[diff], "" >= 9, , sep = "")),
adj = 0, cex = 1.8)
text(10, 0.08, expression(paste(alpha)), adj = 0, col = "red4", cex = 1.8)
text(-11, 0.08, expression(paste(alpha)), adj = 0, col = "red4", cex = 1.8)
text(1, 0.08, expression(paste(beta)), adj = 0, col = "red4", cex = 1.8)
mtext(expression(bar(x)[diff]), side = 1, line = 2, at = 6.5, adj = 0, col = "red4",
cex = 1.8, padj = 0.4)
lines(c(10, 8), c(0.05, 0.01), col = "red4", lwd = 2)
lines(c(-10, -8), c(0.05, 0.01), col = "red4", lwd = 2)
lines(c(2, 4), c(0.05, 0.01), col = "red4", lwd = 2)
7.8 Density Ratios
Part 3…
Show R-Codexbar.therapy <- 92
s.therapy <- 8.5
xbar.placebo <- 85
s.placebo <- 9.1
n <- 15
xdiff <- xbar.therapy - xbar.placebo
sdiff <- sqrt((s.therapy^2 + s.placebo^2)/2) * sqrt(2/n)
sdiff <- sqrt(s.therapy^2 + s.placebo^2)/sqrt(n)
muH0 <- 0
muH1 <- 8
t0 <- (xdiff - muH0)/sdiff
par(cex.main = 1.5, mar = c(4, 4.5, 4.5, 1), mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
par(mar = c(4, 4.5, 4.5, 1))
x <- seq(-15, 30, by = 0.001)
y <- dt(x/sdiff, df = 28)
y3 <- dt((x - 9)/sdiff, df = 28)
plot(x, y, type = "l", axes = FALSE, xlab = NA, ylab = NA, xlim = c(-15, 25),
lwd = 2)
lines(x, y3, lwd = 2)
axis(side = 1, at = seq(-15, 30, by = 5), pos = 0, lwd = 2, cex.axis = 1.7)
axis(side = 1, at = 7, pos = 0, col = "red4", col.axis = "red4", lwd = 2, padj = 0.1)
abline(v = xdiff, col = "red4", lwd = 2)
L0 <- dt((xdiff/sdiff), df = 28)
L2 <- dt(((xdiff - 9)/sdiff), df = 28)
lines(c(6.7, 7.3), y = rep(L0, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L2, 2), col = "red4", lwd = 2)
text(8, L0, expression(paste(italic("L"), " = .04")), adj = 0, col = "red4",
cex = 1.8)
text(7.5, L2, expression(paste(italic("L"), " = .32")), adj = 0, col = "red4",
cex = 1.8)
text(-16, 0.35, expression(paste(H[0], " : ", mu[diff], " = 0", sep = "")), adj = 0,
cex = 1.8)
text(-16, 0.3, expression(paste(H[1], " : ", mu[diff], " = 9", sep = "")), adj = 0,
cex = 1.8)
mtext(expression(bar(x)[diff]), side = 1, line = 2, at = 6.5, adj = 0, col = "red4",
cex = 1.8, padj = 0.1)
text(14, 0.2, expression(paste("LR = ", frac(".32", ".04") %~~% 8, sep = "")),
adj = 0, col = "red4", cex = 1.8)
7.9 Many Density Ratios
Part 4… The take-home message from the last set of plots: use polygon, annotate the plot, and use large font sizes and thick graphical elements.
xbar.therapy <- 92
s.therapy <- 8.5
xbar.placebo <- 85
s.placebo <- 9.1
n <- 15
xdiff <- xbar.therapy - xbar.placebo
sdiff <- sqrt((s.therapy^2 + s.placebo^2)/2) * sqrt(2/n)
sdiff <- sqrt(s.therapy^2 + s.placebo^2)/sqrt(n)
muH0 <- 0
muH1 <- 8
t0 <- (xdiff - muH0)/sdiff
par(cex.main = 1.5, mar = c(4, 4.5, 4.5, 1), mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
par(mar = c(4, 4.5, 4.5, 1))
# Bayes Factor (or, ugliest code ever and I DO NOT CARE TO FIX IT)
x <- seq(-15, 30, by = 0.001)
y <- dt(x/sdiff, df = 28)
y1 <- dt((x - 1)/sdiff, df = 28)
y2 <- dt((x - 2)/sdiff, df = 28)
y3 <- dt((x - 3)/sdiff, df = 28)
y4 <- dt((x - 4)/sdiff, df = 28)
y5 <- dt((x - 5)/sdiff, df = 28)
y6 <- dt((x - 6)/sdiff, df = 28)
y7 <- dt((x - 7)/sdiff, df = 28)
y8 <- dt((x - 8)/sdiff, df = 28)
y9 <- dt((x - 9)/sdiff, df = 28)
y10 <- dt((x - 10)/sdiff, df = 28)
plot(x, y, type = "l", axes = FALSE, xlab = NA, ylab = NA, xlim = c(-15, 25),
lwd = 2)
lines(x, y1, col = "grey70")
lines(x, y2, col = "grey70")
lines(x, y3, col = "grey70", lwd = 2)
lines(x, y4, col = "grey70")
lines(x, y5, col = "grey70", lwd = 2)
lines(x, y6, col = "grey70")
lines(x, y7, col = "grey70")
lines(x, y8, col = "grey70", lwd = 2)
lines(x, y9, col = "grey70")
lines(x, y10, col = "grey70", lwd = 2)
axis(side = 1, at = seq(-15, 30, by = 5), pos = 0, lwd = 2, cex.axis = 1.7)
axis(side = 1, at = 7, pos = 0, col = "red4", col.axis = "red4", lwd = 2, padj = 0.1)
abline(v = xdiff, col = "red4", lwd = 2)
L0 <- dt((xdiff/sdiff), df = 28)
L1 <- dt(((xdiff - 1)/sdiff), df = 28)
L2 <- dt(((xdiff - 2)/sdiff), df = 28)
L3 <- dt(((xdiff - 3)/sdiff), df = 28)
L4 <- dt(((xdiff - 4)/sdiff), df = 28)
L5 <- dt(((xdiff - 5)/sdiff), df = 28)
L6 <- dt(((xdiff - 6)/sdiff), df = 28)
L7 <- dt(((xdiff - 7)/sdiff), df = 28)
L8 <- dt(((xdiff - 8)/sdiff), df = 28)
L9 <- dt(((xdiff - 9)/sdiff), df = 28)
L10 <- dt(((xdiff - 10)/sdiff), df = 28)
lines(c(6.7, 7.3), y = rep(L0, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L1, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L2, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L3, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L4, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L5, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L6, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L7, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L8, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L9, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L10, 2), col = "red4", lwd = 2)
text(-16.8, 0.35, expression(paste(H[0], " : ", mu[diff], " = 0", sep = "")),
adj = 0, cex = 1.6)
text(-16.8, 0.3, expression(paste(H[1], " : 0", "" <= mu[diff], "" <= 10), sep = ""),
adj = 0, cex = 1.6)
text(15, 0.35, expression(paste(italic("L"), "(", H[0], ") = .04")), adj = 0,
col = "red4", cex = 1.6)
text(15, 0.3, expression(paste(italic("L"), "(", H[1], ") = .10")), adj = 0,
col = "red4", cex = 1.6)
text(14.2, 0.22, expression(paste("BF = ", frac(".10", ".04"), " = ", 2.5, sep = "")),
adj = 0, col = "red4", cex = 1.6)
mtext(expression(bar(x)[diff]), side = 1, line = 2, at = 6.5, adj = 0, col = "red4",
cex = 1.8, padj = 0.1)
7.10 Stacked Densities
Michael Lee attended me to a “stacked densities plot” [http://nxn.se/post/97650612370/high-contrast-stacked-distribution-plots].
Quentin Gronau did the work and shows how multiple densities can be
displayed at the same time, while still being discriminable. Note the
use of the trans3d function.
op <- par(mar = c(4, 0, 0, 4))
x <- seq(-12, 12, 0.1)
x.ticks <- seq(-12, 12, 2)
y <- x
z <- matrix(0, ncol = length(x), nrow = length(y))
z[, 1] <- dnorm(x)
zcol <- matrix(0, ncol = length(x), nrow = length(y))
zcol[, 1] <- "black"
res <- persp(x, y, z, theta = 0, phi = 0, expand = 0.4, xlab = "", ylab = "",
ticktype = "detailed", cex.lab = 0.8, zlab = "", box = FALSE, border = FALSE,
xlim = c(-13, 13))
polygon(trans3d(c(x, rev(x)), y = rep(y[1], 2 * length(x)), z = c(dnorm(y, 3.8,
2), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190, blue = 190,
alpha = 100, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[41], 2 * length(x)), z = c(dnorm(y, 6.8),
rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190, blue = 190,
alpha = 140, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[81], 2 * length(x)), z = c(dnorm(y, -1,
2.5), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190,
blue = 190, alpha = 180, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[121], 2 * length(x)), z = c(dnorm(y,
-5), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190, blue = 190,
alpha = 220, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[161], 2 * length(x)), z = c(dnorm(y,
2.5, 1.5), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190,
blue = 190, alpha = 260, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[201], 2 * length(x)), z = c(dnorm(y,
-9, 0.8), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190,
blue = 190, alpha = 300, maxColorValue = 300), border = NA)
### draw x-axis
lines(trans3d(x[which(x == -8):which(x == 10)], min(y) - 2, min(z), res), col = "black",
lwd = 1.4)
# tick marks
tick.start <- trans3d(seq(-8, 10, 2), min(y) - 2, min(z), res)
tick.end <- trans3d(seq(-8, 10, 2), min(y) - 2, min(z - 0.01), res)
segments(tick.start$x, tick.start$y, tick.end$x, tick.end$y, lwd = 2.6)
# labels
labels <- seq(-8, -2, 2)
label.pos <- trans3d(seq(-8, -2, 2), min(y) - 2, min(z - 0.035), res)
text(label.pos$x, label.pos$y, labels = labels, cex = 1.6, adj = 0.65)
labels <- seq(0, 10, 2)
label.pos <- trans3d(seq(0, 10, 2), min(y) - 2, min(z - 0.035), res)
text(label.pos$x, label.pos$y, labels = labels, cex = 1.6, adj = 0.5)
### add labels to distributions
text(trans3d(3.8, y[1], dnorm(3.8, 3.8, 2) + 0.02, res), "a", cex = 1.7)
text(trans3d(6.8, y[41], dnorm(6.8, 6.8) + 0.024, res), "b", cex = 1.7)
text(trans3d(-1, y[81], dnorm(-1, -1, 2.5) + 0.027, res), "c", cex = 1.7)
text(trans3d(-5, y[121], dnorm(-5, -5) + 0.029, res), "d", cex = 1.7)
text(trans3d(2.5, y[161], dnorm(2.5, 2.5, 1.5) + 0.033, res), "e", cex = 1.7)
text(trans3d(-9, y[201], dnorm(-9, -9, 0.8) + 0.039, res), "f", cex = 1.7)
par(op)
8 Functions
It can be very informative to plot a function. This is relatively straightforward once you stick to the basic principles (thick lines, annotate the plot, large font sizes).
8.1 Plotting a Function
What did we say? Thick lines, annotate the plot, large font sizes!
Show R-CodeMax.BF10 = function(p) {
# Computes the upper bound on the Bayes factor As in Sellke, Bayarri, &
# Berger, 2001
Max.BF10 <- -1/(exp(1) * p * log(p))
return(Max.BF10)
}
# Plot this function for p in .001 to .1
xlow <- 0.001
xhigh <- 0.1
p1 <- 0.0373
p2 <- 0.00752
p3 <- 0.001968
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
plot(function(p) Max.BF10(p), xlow, xhigh, xlim = c(xlow, xhigh), lwd = 2, xlab = " ",
ylab = " ")
mtext("Two-sided p value", 1, line = 2.5, cex = 1.5, font = 2)
mtext("Maximum Bayes factor for H1", 2, line = 2.8, cex = 1.5, font = 2, las = 0)
lines(c(0, p1), c(3, 3), lwd = 2, col = "grey")
lines(c(0, p2), c(10, 10), lwd = 2, col = "grey")
lines(c(0, p3), c(30, 30), lwd = 2, col = "grey")
lines(c(p1, p1), c(0, 3), lwd = 2, col = "grey")
lines(c(p2, p2), c(0, 10), lwd = 2, col = "grey")
lines(c(p3, p3), c(0, 30), lwd = 2, col = "grey")
cexsize <- 1.2
text(0.005, 31, expression(max((BF[10])) == 30 %<->% p %~~% 0.002), cex = cexsize,
pos = 4)
text(0.01, 11, expression(max((BF[10])) == 10 %<->% p %~~% 0.008), cex = cexsize,
pos = 4)
text(p1 - 0.005, 5, expression(max((BF[10])) == 3 %<->% p %~~% 0.037), cex = cexsize,
pos = 4)
9 Time Series
What’s not to love about time series? In constrast to some of the previous plots, time series are virtually always interesting, almost mesmerizing. The bar plot compares to a time series as, well, a refrigerator compares to Marilin Monroe. The reason, of course, is that time series are highly informative: they usually contain many observations; moreover, they show how particular variables change over time (it is a time series, after all). Enough of the talking – let’s turn to some examples.
9.1 A Diffusion Process
Instead of giving a lecture about diffusion processes, I’ll point out that the lines are transparent. We’ve encountered this before but it was Guy Hawkins who showed me how to do this in R.
Show R-Codegendat = function(ndat = 1000, dt = 0.1) {
# Outputs a sequence of Brownian motion data
dat <- array()
dat[1] <- rnorm(1, mean = 0, sd = sqrt(dt))
for (j in 1:(ndat - 1)) {
drift <- 0
diffvar <- 1
error <- rnorm(1, 0, sqrt(diffvar * dt))
dat[j + 1] <- dat[j] + drift * dt + error # Cobb & Zacks (1985), Eq. 1.14
}
invisible(dat) # same as 'return', but without printing to console
}
## General settings:
dt <- 0.1
ntime <- 1000
times <- c(1:ntime)
nsims <- 1000
# Plot settings:
ylow <- -40
yhigh <- 40
xhigh <- 1.3 * ntime
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 170, maxColorValue = 255)
# For transparent lines set, set 'alpha' between 0 (invisible) and 255
# (opaque)
op <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
plot(times, gendat(ndat = ntime, dt), type = "l", lwd = 1, main = "", ylab = "",
xlab = "", axes = FALSE, ylim = c(ylow, yhigh), xlim = c(0, xhigh), cex.lab = 1,
font.lab = 2, cex.axis = 0.9, col = greycol, bty = "n")
axis(1, at = c(0, 200, 400, 600, 800, 1000), lab = c("0", "20", "40", "60", "80",
"100"))
# NB the labels are divided by 10 because dt = .1
axis(2)
par(las = 0)
mtext("Time", side = 1, line = 2.5, cex = 1.5, at = 500)
mtext("Evidence", side = 2, line = 2.8, cex = 1.5)
lines(c(1, ntime), c(0, 0), lwd = 1, lty = 2, col = "black")
for (i in 1:9) {
par(new = TRUE)
plot(times, gendat(ndat = ntime, dt), type = "l", lwd = 1, main = "", ylab = "",
xlab = "", axes = FALSE, ylim = c(ylow, yhigh), xlim = c(0, xhigh), cex.lab = 1,
font.lab = 2, cex.axis = 0.9, col = greycol, bty = "n")
}
std <- sqrt(ntime * dt)
c <- 7000 # A multiplication factor so the Normal density is visible
df1 <- data.frame(yval = seq(from = -35, to = 35, by = 0.1), xval = (dnorm(seq(from = -35,
to = 35, by = 0.1), 0, std) * c))
with(df1, lines(xval + ntime + 20, yval, lwd = 2))
# Optional: Check by simulation and plot density estimate
do.sim <- FALSE
if (do.sim == TRUE) {
x <- array()
for (i in 1:nsims) {
x[i] <- gendat(ntime, dt)[ntime] # end point of simulation process
}
startx <- ntime + 20
yhigh.c <- yhigh * c
y <- density(x)
lines((y$y * c) + startx, y$x, lwd = 2, col = greycol)
}
par(op)
9.2 A Sequence of Choices
Helen Steingroever returns to us once again, this time with a choice profile for the Iowa gambling task. The plot conveys a lot of information: for one participant, the plot indicates the sequence of 100 choices among four choice alternatives, and whether or not each choice resulted in a win or a loss.
Show R-Code# rm(list = ls())
IndividualPerformance <- function(choice, lo, show.losses = FALSE) {
# Plots the choice profile Args: choice: A vector containing the choices on
# each trial lo: A vector containing the losses on each trial show.losses:
# logical: Should the losses be indicated by filled dots?
par(mar = c(4, 4.5, 0.5, 1))
plot(choice, type = "b", axes = FALSE, xlab = "Trial", ylab = "Deck", cex.lab = 2)
axis(1, seq(0, 100, length = 6), cex.axis = 1.8)
axis(2, 1:4, labels = c("A", "B", "C", "D"), cex.axis = 1.8, las = 1)
if (show.losses == TRUE) {
index.losses <- which(lo < 0)
points(matrix(c(index.losses, choice[index.losses]), byrow = FALSE, nrow = length(index.losses)),
pch = 19, lwd = 1.5)
}
}
# Synthetic data
choice <- sample(1:4, 100, replace = TRUE)
lo <- sample(c(-1250, -250, -50, 0), 100, replace = TRUE)
# postscript('DiversePerformance.eps', width = 7, height = 7)
IndividualPerformance(choice, lo, show.losses = TRUE)
# dev.off()
9.3 The Electoral Advantage of Being Tall Revisited
This plot shows the development of the Bayes factor (y-axis) as the data accumulate (x-axis). This procedure may give frequentists a heart attack but, in Bayes world, that’s just how we roll. What we like about the graph are the annotations on the right side of the plot, and the subtle horizontal lines that indicate Jeffreys’ criteria on the evidence. It took some time to figure out how to display the word “Evidence” in its current direction. To make this plot we “borrowed” code from Ruud Wetzels and Benjamin Scheibehenne.
Show R-Code# rm(list=ls())
# height of president divided by height of most successful opponent:
height.ratio <- c(0.924324324, 1.081871345, 1, 0.971098266, 1.029761905,
0.935135135, 0.994252874, 0.908163265, 1.045714286, 1.18404908, 1.115606936,
0.971910112, 0.97752809, 0.978609626, 1, 0.933333333, 1.071428571,
0.944444444, 0.944444444, 1.017142857, 1.011111111, 1.011235955, 1.011235955,
1.089285714, 0.988888889, 1.011111111, 1.032967033, 1.044444444, 1,
1.086705202, 1.011560694, 1.005617978, 1.005617978, 1.005494505, 1.072222222,
1.011111111, 0.983783784, 0.967213115, 1.04519774, 1.027777778, 1.086705202,
1, 1.005347594, 0.983783784, 0.943005181, 1.057142857)
# proportion popular vote for president vs most successful opponent
pop.vote <- c(0.427780852, 0.56148981, 0.597141922, 0.581254292, 0.530344067,
0.507425996, 0.526679292, 0.536690951, 0.577825976, 0.573225387, 0.550410082,
0.559380032, 0.484823958, 0.500466176, 0.502934212, 0.49569636, 0.516904414,
0.522050547, 0.531494442, 0.60014892, 0.545079801, 0.604274986, 0.51635906,
0.63850958, 0.652184407, 0.587920412, 0.5914898, 0.624614752, 0.550040193,
0.537771958, 0.523673642, 0.554517134, 0.577511576, 0.500856251, 0.613444534,
0.504063153, 0.617883695, 0.51049949, 0.553073235, 0.59166415, 0.538982024,
0.53455133, 0.547304058, 0.497350649, 0.512424242, 0.536914796)
## now calculate BF sequentially; two-sided test
library("hypergeo")
BF10.HG.exact = function(n, r) {
# Jeffreys' test for whether a correlation is zero or not Jeffreys
# (1961), pp. 289-292 Note that if the means are subtracted, n needs to
# be replaced by n-1
hypgeo = hypergeo((0.25 + n/2), (-0.25 + n/2), (3/2 + n/2), r^2)
BF10 = (sqrt(pi) * gamma(n/2 + 1) * (hypgeo))/(2 * gamma(3/2 + n/2))
return(as.numeric(BF10))
}
BF10 <- array()
BF10[1] <- 1
BF10[2] <- 1
for (i in 3:length(height.ratio)) {
BF10[i] <- BF10.HG.exact(n = i - 1, r = cor(height.ratio[1:i], pop.vote[1:i]))
}
# We wish to plot this Bayes factor sequentially, as it unfolds as more
# elections become available: ============ Plot log Bayes factors ================
par(cex.main = 1.3, mar = c(4.5, 6, 4, 7) + 0.1, mgp = c(3, 1, 0), cex.lab = 1.3,
font.lab = 2, cex.axis = 1.3, las = 1)
xhigh <- 60
plot(log(BF10), xlim = c(1, xhigh), ylim = c(-1 * log(200), log(200)),
xlab = "", ylab = "", cex.lab = 1.3, cex.axis = 1.3, las = 1, yaxt = "n",
bty = "n", type = "p", pch = 21, bg = "grey")
labelsUpper = log(c(100, 30, 10, 3, 1))
labelsLower = -1 * labelsUpper
criticalP = c(labelsLower, 0, labelsUpper)
for (idx in 1:length(criticalP)) {
abline(h = criticalP[idx], col = "darkgrey", lwd = 1, lty = 2)
}
abline(h = 0)
axis(side = 4, at = criticalP, tick = TRUE, las = 2, cex.axis = 1, labels = FALSE)
axis(side = 4, at = labelsUpper + 0.602, tick = FALSE, cex.axis = 1, labels = c("Extreme",
"Very strong", "Strong", "Moderate", "Anecdotal"))
axis(side = 4, at = labelsLower - 0.602, tick = FALSE, cex.axis = 1, labels = c("Extreme",
"Very strong", "Strong", "Moderate", "Anecdotal"))
axis(side = 2, at = c(criticalP), tick = TRUE, las = 2, cex.axis = 1, labels = c("1/100",
"1/30", "1/10", "1/3", "1", "", "100", "30", "10", "3", ""))
mtext(expression(BF[1][0]), side = 2, line = 2.5, las = 0, cex = 1.3)
grid::grid.text("Evidence", 0.97, 0.5, rot = 270, gp = grid::gpar(cex = 1.3))
mtext("No. of Elections", side = 1, line = 2.5, las = 1, cex = 1.3)
arrows(20, -log(10), 20, -log(100), length = 0.25, angle = 30, code = 2,
lwd = 2)
arrows(20, log(10), 20, log(100), length = 0.25, angle = 30, code = 2,
lwd = 2)
text(25, -log(70), "Evidence for H0", pos = 4, cex = 1.3)
text(25, log(70), "Evidence for H1", pos = 4, cex = 1.3)
9.4 A Sequential Test on
And again the Bayesians flaunt their disdain for the sillyness of sampling plans. The plot below shows the development of the Bayes factor (y-axis) with the number of digits from . As the digits accumulate, so does the evidence in favor of the null hypothesis (yes frequentists, you read that right – evidence in favor of the null hypothesis).
The plot shows the maximum evidence (in red), the actual evidence (for two different priors), and the area that we can expect the Bayes factor be in of the cases, should the null hypothesis hold. This is dirty frequentist reasoning of course, but the plot does show how it is possible to reject a null hypothesis even when the data provide a lot of support in its favor (i.e., the Jeffreys-Lindley paradox). Courtesy of Quentin Gronau.
Show R-Codelibrary(plotrix)
### plot multinomial BF
load("BFMultiPi.rda")
load("maxBFMultiPi.rda")
load("exBFMultiPi.rda")
N <- seq(1000, 1e+08, 1000)
par(cex.main = 1.3, mar = c(4.5, 6, 4, 7) + 0.1, mgp = c(3, 1, 0), cex.lab = 1.3,
font.lab = 2, cex.axis = 1.3, las = 1)
plot(c(0, log(BFMultiPi)), xlim = c(0, 100001), ylim = c(-20, 80), xlab = "",
ylab = "", cex.lab = 1.3, cex.axis = 1.3, las = 1, yaxt = "n", bty = "n",
type = "n", pch = 21, bg = "grey", axes = FALSE, lwd = 4, main = expression(paste("Multinomial",
~logBF[0][1], ~"for", ~pi, sep = " ")), cex.main = 2)
axis(2, at = seq(-20, 80, 20), labels = seq(-20, 80, 20))
options(scipen = 100, digits = 4)
axis(1, at = seq(from = 0, to = 1e+05, by = 10000), labels = seq(from = 0,
to = 1e+05, by = 10000))
ablineclip(h = 0, lty = 2, x2 = 1e+05, y2 = 0)
mtext(expression(logBF[0][1]), side = 2, line = 3.1, las = 0, cex = 1.7)
mtext(expression("No. of Decimal Places of" ~ pi ~ "(No./1000)"), side = 1,
line = 3.1, las = 1, cex = 1.3)
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 170, maxColorValue = 255)
points(c(0, seq_along(N)), c(0, log(maxBFMultiPi)), type = "l", lwd = 4,
col = "red")
points(c(0, seq_along(N)), c(0, log(exBFMultiPi)), type = "l", lwd = 3,
col = greycol)
yy <- c(log(maxBFMultiPi), rev(log(exBFMultiPi)))
xx <- c(N/1000, rev(N/1000))
polygon(xx, yy, col = greycol)
text(10000, 7, "Evidence for H0", pos = 4, cex = 1.3)
text(10000, -7, "Evidence for H1", pos = 4, cex = 1.3)
arrows(7000, -2, 7000, -14, length = 0.25, angle = 30, code = 2, lwd = 2)
arrows(7000, 2, 7000, 14, length = 0.25, angle = 30, code = 2, lwd = 2)
points(c(0, seq_along(N)), c(0, log(BFMultiPi)), type = "l", lwd = 3,
col = "black")
op <- par(lend = 1)
legend(x = 54000, 45, legend = c(expression(max.BF[0][1]), expression(BF[0][1]),
expression("95%" ~ BF[0][1] ~ "|" ~ H[0])), lty = c(1, 1, 1), lwd = c(3,
3, 20), col = c("red", "black", greycol), bty = "n", x.intersp = 0.5,
cex = 1.2)
par(op)
text(39600, 76, "D(a=1)", cex = 1.3)
text(40000, 34.5, "D(a=50)", cex = 1.3)
# add Dirichlet a=50 prior
load("BFMultiPi50.rda")
load("maxBFMultiPi50.rda")
load("exBFMultiPi50.rda")
greycol2 <- rgb(red = 190, green = 190, blue = 190, alpha = 60, maxColorValue = 255)
yy <- c(log(maxBFMultiPi50), rev(log(exBFMultiPi50)))
xx <- c(N/1000, rev(N/1000))
polygon(xx, yy, col = greycol2)
red2 <- rgb(red = 255, green = 0, blue = 0, alpha = 80, maxColorValue = 255)
points(c(0, seq_along(N)), c(0, (log(maxBFMultiPi50))), type = "l", lwd = 4,
col = red2, lty = 1)
black2 <- red2 <- rgb(red = 100, green = 100, blue = 100, alpha = 200,
maxColorValue = 300)
points(c(0, seq_along(N)), c(0, (log(BFMultiPi50))), type = "l", lwd = 4,
lty = 1, col = black2)
10 Multiple Panels
To suitably impress the readership, any academic needs to be able to create a multi-panel graph. Below is a set of examples. When creating a multi-panel plot, the main challenge is to select the right number of panels (yes, you can have too many) so that the text and the symbols remain readible.
10.1 Two panel plot
This is one of my favorite plots, highlighting the difference between discrete probability mass and continous probability density. Credit goes to Michael Lee for conceptualizing the graph (it is presented in box 3.2 of our book) and to Quentin Gronau for the execution in R. Note the use of ablineclip for lines of distinct length and uniroot for finding the x-value that corresponds to five times the density of another x-value.
Show R-Codelibrary(plotrix)
# mix of 2 normal distributions
mixedNorm <- function(x) {
return(0.5 * dnorm(x, 0.25, 0.13) + 0.5 * dnorm(x, 0.7, 0.082))
}
### normalize so that area [0,1] integrates to 1; k = normalizing constant
k <- 1/integrate(mixedNorm, 0, 1)$value
# normalized
pdfmix <- function(x, k) {
return(k * (0.5 * dnorm(x, 0.25, 0.13) + 0.5 * dnorm(x, 0.7, 0.082)))
}
# integrate(pdfmix, 0.0790321,0.4048)$value # 0.4
op <- par(mfrow = c(1, 2), mar = c(5.9, 6, 4, 2) + 0.1)
barplot(height = c(0.2, 0.25, 0.1, 0.05, 0.35, 0.05), names.arg = c(1,
2, 3, 4, 5, 6), axes = FALSE, ylim = c(0, 1), width = 1, cex.names = 1.5)
arrows(x0 = 0.6, x1 = 0.6, y0 = 0.38, y1 = 0.23, length = c(0.2, 0.2),
lwd = 2)
text(0.6, 0.41, "0.2", cex = 1.3)
ablineclip(v = 1.9, y1 = 0.28, y2 = 0.375, lwd = 2)
ablineclip(v = 4.2, y1 = 0.28, y2 = 0.375, lwd = 2)
ablineclip(h = 0.375, x1 = 1.9, x2 = 4.2, lwd = 2)
arrows(x0 = 3.05, x1 = 3.05, y0 = 0.525, y1 = 0.375, length = c(0.2, 0.2),
lwd = 2)
text(3.05, 0.555, "0.4", cex = 1.3)
ablineclip(v = 5.5, y1 = 0.38, y2 = 0.43, lwd = 2)
arrows(x0 = 6.7, x1 = 6.7, y0 = 0.43, y1 = 0.09, length = c(0.2, 0.2),
lwd = 2)
ablineclip(h = 0.43, x1 = 5.5, x2 = 6.7, lwd = 2)
text(6.1, 0.46, "7 x", cex = 1.3)
par(las = 1)
axis(2, at = seq(0, 1, 0.1), labels = seq(0, 1, 0.1), lwd = 2, cex.axis = 1.3)
par(las = 0)
mtext("Probability Mass", side = 2, line = 3.7, cex = 2)
mtext("Value", side = 1, line = 3.7, cex = 2)
par(mar = c(4.6, 6, 3.3, 2) + 0.1)
xx <- c(0.0790321, 0.079031, seq(0.08, 0.4, 0.01), 0.4084, 0.4084)
yy <- c(0, pdfmix(0.079031, k = k), pdfmix(seq(0.08, 0.4, 0.01), k = k), pdfmix(0.4084, k = k),
0)
plot(1, type = "n", axes = FALSE, ylab = "", xlab = "", xlim = c(0, 1),
ylim = c(0, 3))
polygon(xx, yy, col = "grey", border = NA)
curve(pdfmix(x, k = k), from = 0, to = 1, lwd = 2, ylab = "", xlab = "", xlim = c(0,
1), ylim = c(0, 3), add = TRUE)
text(0.25, 0.7, "0.4", cex = 1.3)
par(las = 1)
axis(2, at = seq(0, 3, 0.5), labels = seq(0, 3, 0.5), lwd = 2, cex.axis = 1.3)
points(0.539580297, pdfmix(0.539580297, k = k), pch = 21, bg = "white", cex = 1.4,
lwd = 2.7)
points(uniroot(function(x) pdfmix(x, k = k) - 5 * pdfmix(0.539580297, k = k), interval = c(0.56,
0.7))$root, pdfmix(uniroot(function(x) pdfmix(x, k = k) - 5 * pdfmix(0.539580297, k = k),
interval = c(0.56, 0.7))$root, k = k), pch = 21, bg = "white", cex = 1.4,
lwd = 2.7)
arrows(x0 = 0.539580297, x1 = 0.539580297, y0 = 2.7, y1 = 0.7, length = c(0.17,
0.17), angle = 19, lwd = 2)
ablineclip(h = 2.7, x1 = 0.539580297, x2 = 0.6994507, lwd = 2)
ablineclip(v = 0.6994507, y1 = 2.55, y2 = 2.7, lwd = 2)
text(0.6194593, 2.79, "5 x", cex = 1.3)
axis(1, at = seq(0, 1, 0.1), labels = c("0", ".1", ".2", ".3", ".4", ".5",
".6", ".7", ".8", ".9", "1"), line = -1.2, lwd = 2, cex.axis = 1.37)
par(las = 0)
mtext("Probability Density", side = 2, line = 3.7, cex = 2)
mtext("Value", side = 1, line = 2.4, cex = 2)
par(op)
10.2 Buffon’s Needle
The only way to understand the title (and the plot) is to visit the Wikipedia entry on Buffon’s needle. Anyway, this is another two-panel plot, showing two posterior distributions for estimating using an experiment that involved tossing a needle (ad nauseam).
Show R-Codelibrary(plotrix)
source("HDIofMCMC.R")
load("mcmcChain1.rda")
load("mcmcChain2.rda")
op <- par(mfrow = c(1, 2))
par(cex.main = 1.5, mar = c(5.5, 5.5, 5.9, 3) + 0.1, mgp = c(3.5, 1, 0),
cex.lab = 1.5, font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
y <- hist(mcmcChain1[, "pihat"], freq = F, main = "", xlab = "", ylab = " ",
xlim = c(2.1, 5.1), axes = FALSE, breaks = 24, ylim = c(0, 2), yaxt = "n",
col = "grey")
axis(1, at = c(2.1, 2.6, pi, 3.6, 4.1, 4.6, 5.1), labels = c(2.1, 2.6,
expression(pi), 3.6, 4.1, 4.6, 5.1), lwd = 2, lwd.ticks = 2, line = -0.1)
ablineclip(h = 0, x1 = 5.1, col = "white")
axis(2, at = seq(0, 2, 0.5), line = -0.2, lwd = 2, lwd.ticks = 2)
mtext(expression(hat(pi)), side = 1, line = 4, cex = 2.4, font = 2, adj = 0.5)
mtext("Density", side = 2, line = 3.7, cex = 2.4, font = 2, las = 0)
lines(density(mcmcChain1[, "pihat"], from = 2.1, to = 5.1), lwd = 4)
HDI <- HDIofMCMC(mcmcChain1[, "pihat"])
arrows(x0 = HDI[1], y0 = 1.4, x1 = HDI[2], y1 = 1.4, angle = 90, length = 0.1,
code = 3, lwd = 2.2)
text("95% HDI", x = mean(HDI), y = 1.48, cex = 1.8)
text(expression(P(cross) ~ "= .5"), x = 3.99, y = 1, cex = 1.5)
par(cex.main = 1.5, mar = c(5.5, 5.5, 5.9, 3) + 0.1, mgp = c(3.5, 1, 0),
cex.lab = 1.5, font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
h <- hist(mcmcChain2[, "pihat"], freq = F, main = "", xlab = "", ylab = " ",
xlim = c(2.1, 5.1), axes = FALSE, col = "grey", breaks = 17, ylim = c(0,
2), , xaxt = "n")
axis(1, at = c(2.1, 2.6, pi, 3.6, 4.1, 4.6, 5.1), labels = c(2.1, 2.6,
expression(pi), 3.6, 4.1, 4.6, 5.1), lwd = 2, lwd.ticks = 2, line = -0.1)
axis(2, at = seq(0, 2, 0.5), lwd = 2, lwd.ticks = 2, line = -0.2)
mtext(expression(hat(pi)), side = 1, line = 4, cex = 2.4, font = 2, adj = 0.5)
mtext("Density", side = 2, line = 3.7, cex = 2.4, font = 2, las = 0)
lines(density(mcmcChain2[, "pihat"], from = 2.1, to = 5.1), lwd = 4)
HDI <- HDIofMCMC(mcmcChain2[, "pihat"])
arrows(x0 = HDI[1], y0 = 1.73, x1 = HDI[2], y1 = 1.73, angle = 90, length = 0.1,
code = 3, lwd = 2.2)
text("95% HDI", x = mean(HDI), y = 1.81, cex = 1.8)
text(expression(P(cross) ~ "= .63"), x = 4.12, y = 1, cex = 1.5)
mtext(expression("Posterior of" ~ hat(pi)), side = 3, line = -4.6, outer = TRUE,
cex = 3.3)
par(op)
10.3 Anscombe’s Quartet
Sometimes a graph is worth a thousand words. Anscombe’s quartet famously drives home the idea that you should always plot your data. This code is based on the Anscombe plot in R. We personally don’t like lapply and similar complications – it may do the trick but when you have to describe the code as “magic” this signals a communication problem. Anyway, the point of the example is graphical display of course. As always, note the thick lines, the large symbols, and the large font size.
Show R-Code# rm(list = ls())
library(stats)
library(graphics)
library(plotrix)
# summary(anscombe) -- now some 'magic' to do the 4 regressions in a
# loop:
ff <- y ~ x
for (i in 1:4) {
ff[2:3] <- lapply(paste(c("y", "x"), i, sep = ""), as.name)
## or ff[[2]] <- as.name(paste('y', i, sep='')) ff[[3]] <-
## as.name(paste('x', i, sep=''))
assign(paste("lm.", i, sep = ""), lmi <- lm(ff, data = anscombe))
# print(anova(lmi))
}
op <- par(mfrow = c(2, 2), mar = 0.1 + c(4, 4, 1, 1), oma = c(0, 0, 2,
0), cex.lab = 1.5, font.lab = 1.5, cex.axis = 1.3, bty = "n", las = 1,
cex.main = 1.5)
for (i in 1:4) {
ff[2:3] <- lapply(paste(c("y", "x"), i, sep = ""), as.name)
plot(ff, data = anscombe, col = "black", pch = 21, bg = "grey", cex = 2,
xlim = c(3, 21), ylim = c(3, 13), ylab = "", xlab = "", axes = F)
axis(1, at = seq(3, 21, 3))
axis(2)
text(15, 6, "r = 0.816", cex = 1.5)
# mtext(ff[2:3][[1]], side=2, line=2.5, cex=1.3) #y-labels
# mtext(ff[2:3][[2]], side=1, line=2.5, cex=1.3) #x-labels
ablineclip(get(paste("lm.", i, sep = "")), x1 = 3, x2 = 21, col = "black",
lwd = 2)
}
mtext("Anscombe's Quartet", outer = TRUE, cex = 1.5)
par(op)
10.4 Four Quite Different Panels
Each panel of this plot shows something very different: histogram, density, point plot, and function. We like the annotations too.
Show R-Code################################## load data #############
# Social Priming Research, all between-subject studies, N=159:
dataSocialPriming <- read.csv("SocialPriming.csv", sep = ";")
# Control Studies, between-subject, N=130:
dataControlsSocialPriming <- read.csv("ControlsSocialPriming.csv", sep = ";")
# p values
pValuesSocialPriming <- dataSocialPriming$pvalue
pValuesControlsSocialPriming <- dataControlsSocialPriming$pvalue
################################## 4-panel plot ###########
source("HDIofMCMC.R")
plotphi <- function(samples, Nbreaks = 80, xlow = 0, xhigh = 1, ylow = 0,
yhigh = 10) {
# Plots the mixture proportion p(H0)
phi <- samples$BUGSoutput$sims.list$phi
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0),
cex.lab = 1.5, font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
y <- hist(phi, Nbreaks, plot = F)
plot(c(y$breaks, max(y$breaks)), c(0, y$density, 0), type = "S", lwd = 2,
lty = 1, xlim = c(xlow, xhigh), ylim = c(ylow, yhigh), xlab = "",
ylab = "", col = "black")
mtext("H0 Assignment Rate", side = 1, line = 2.7, cex = 1.5)
par(las = 0)
mtext("Posterior Density", side = 2, line = 2.5, cex = 1.5)
lines(c(0.5, 0.5), c(ylow, yhigh), cex = 2, lty = 2)
}
plotz <- function(pvals, samples) {
# Plots the p-value against the probability of being classified as from H0
z <- samples$BUGSoutput$mean$ind
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0),
cex.lab = 1.5, font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
plot(sort(pvals, dec = TRUE), z, col = "black", pch = 21, bg = "grey",
cex = 2, xlim = c(0, 0.05), ylim = c(0, 1), ylab = "", xlab = "",
axes = F)
axis(1)
axis(2)
par(las = 0)
mtext("Significant P Values", side = 1, line = 2.9, cex = 1.5)
mtext("Probability H0 Assignment", side = 2, line = 3.5, cex = 1.5)
lines(c(0, 0.05), c(0.5, 0.5), cex = 2, lty = 2)
}
plotpredqq <- function(pvals, samples, ks.test = FALSE) {
# Draws qq plot; computes ks test
predp <- pnorm(samples$BUGSoutput$sims.list$predqp)
par(cex.main = 1.5, mar = c(5, 6, 4, 4) + 0.1, mgp = c(3.5, 1, 0),
cex.lab = 1.5, font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
qqplot(pvals, predp, xlab = "", ylab = "", axes = F, col = "black")
axis(1)
axis(2)
mtext("Observed P Value Quantiles", side = 1, line = 2.9, cex = 1.5)
par(las = 0)
mtext("Predicted Quantiles ", side = 2, line = 3.7, cex = 1.7)
abline(a = 0, b = 1, lty = 3)
if (ks.test == TRUE)
ks.test(pvals, predp)
}
histP <- function(pvals, samples, yhigh = 100, col = "lightblue") {
# Plots histogram of the p-values
predp <- pnorm(samples$BUGSoutput$sims.list$predqp)
par(cex.main = 1.5, mar = c(5, 6, 4, 4) + 0.1, mgp = c(3.5, 1, 0),
cex.lab = 1.5, font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
hist(pvals, freq = TRUE, xlab = "", ylab = "", col = col, main = "",
ylim = c(0, yhigh), xlim = c(0, 0.05), axes = F)
axis(1)
par(las = 1)
axis(2)
mtext("Significant P Values", side = 1, line = 2.9, cex = 1.5)
par(las = 0)
mtext("Number of P Values", side = 2, line = 3.3, cex = 1.6)
rug(pvals)
}
### load samples
load("samplesSocialPriming_DirichletJags.Rdata")
load("samplesControlsSocialPriming_DirichletJags.Rdata")
pvals <- pValuesSocialPriming
pvals2 <- pValuesControlsSocialPriming
samplesP <- samplesSocialPriming_DirichletJags
samplesP2 <- samplesControlsSocialPriming_DirichletJags
### create plot
op <- par(mfrow = c(2, 2))
yhigh <- 80
greycol2 <- rgb(0, 0, 0, alpha = 0.7)
histP(pvals, samplesP, yhigh, col = greycol2)
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 95, maxColorValue = 255)
hist(pvals2, freq = TRUE, xlab = "", ylab = "", main = "", ylim = c(0,
yhigh), xlim = c(0, 0.05), col = greycol, axes = F, add = TRUE, lty = 2)
op2 <- par(lend = 1)
legend(x = 0.006, 45, legend = c("Social Priming Studies (N=159)", "Control Studies (N=130)"),
lty = c(1, 1, 1), lwd = c(15, 15), col = c(greycol2, greycol), bty = "n",
x.intersp = 0.5, cex = 1.4)
par(op2)
plotphi(samplesP, yhigh = 6)
Nbreaks <- 80
xlow <- 0
xhigh <- 1
ylow <- 0
yhigh <- 10
phi1 <- samplesP$BUGSoutput$sims.list$phi
phi2 <- samplesP2$BUGSoutput$sims.list$phi
y <- hist(phi2, Nbreaks, plot = F)
greycol2 <- rgb(0, 0, 0, alpha = 0.5)
lines(c(y$breaks, max(y$breaks)), c(0, y$density, 0), lwd = 2, lty = 1,
col = greycol2)
par(las = 1)
text(0.91, 2.7, c("Social \nPriming \nStudies"), cex = 1.3)
text(0.09, 3.5, c("Control \nStudies"), cex = 1.3)
HDI1 <- HDIofMCMC(phi1) # [0.414, 0.865]
HDI2 <- HDIofMCMC(phi2) # [0.061, 0.446]
arrows(x0 = HDI1[1], y0 = 4, x1 = HDI1[2], y1 = 4, angle = 90, code = 3,
length = 0.08)
mtext("95%", side = 3, at = mean(HDI1), line = -5)
arrows(x0 = HDI2[1], y0 = 4.8, x1 = HDI2[2], y1 = 4.8, angle = 90, code = 3,
length = 0.08, col = greycol2)
mtext("95%", side = 3, at = mean(HDI2), line = -3.1, col = greycol2)
plotz(pvals, samplesP)
z <- samplesP2$BUGSoutput$mean$ind
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 40, maxColorValue = 255)
greycol2 <- rgb(0, 0, 0, alpha = 0.12)
points(sort(pvals2, dec = TRUE), z, col = greycol2, pch = 21, bg = greycol,
cex = 2)
text(0.02, 0.92, "Social Priming Studies", cex = 1.4, pos = 4)
text(0.025, 0.38, "Control Studies", cex = 1.4, pos = 4)
plotpredqq(pvals, samplesP)
predp <- pnorm(samplesP2$BUGSoutput$sims.list$predqp)
d <- qqplot(pvals2, predp, xlab = "", ylab = "", axes = FALSE, plot = FALSE)
greycol2 <- rgb(0, 0, 0, alpha = 0.3)
points(d$x, d$y, col = greycol2)
legend(0.019, 0.019, legend = c("Social Priming Studies", "Control Studies"),
pch = rep(1, 2), col = c("black", greycol2), lwd = c(2.3, 2.3), lty = c(NA,
NA), bty = "n", x.intersp = 0, cex = 1.4)
par(op)
10.5 Nine-Panel Posterior Predictives
Ravi Selker enters the stage to present a nine-panel plot of posterior predictives. Note the use of textGrob and arrangeGrob. Nice work.
Show R-Codelibrary(ggmcmc)
library(gridExtra)
library(grid)
Mode <- function(x) {
ux <- unique(x)
ux[which.max(tabulate(match(x, ux)))]
}
load("PostPredCheck.Rdata")
############################################## GRAPHS ###
postpred <- list()
for (i in 1:3) postpred[[i]] <- list()
for (i in 1:3) {
for (j in 1:3) {
postpred[[i]][[j]] <- ggplot(data[[i]][[j]], aes(x = ypred, y = yobs,
size = factor(nrow))) + geom_point() + coord_flip() + theme(panel.grid.minor = element_blank(),
plot.title = element_blank(), panel.grid.major = element_blank(),
legend.position = "none", axis.title.x = element_blank(),
axis.title.y = element_blank(), axis.text.x = element_text(size = 14),
axis.text.y = element_text(size = 14), panel.background = element_rect(fill = "white",
colour = "white"), panel.border = element_blank(), axis.line = element_line(size = 1.1),
plot.margin = unit(c(0.1, 0.1, 0.1, 0.1), "cm")) + geom_abline(size = 1.1)
}
}
############################################## PLOT ALL GRAPHS IN ONE FIGURE ###
T1 <- textGrob("1 Truth", gp = gpar(cex = 1.5))
T2 <- textGrob("2 Truths", gp = gpar(cex = 1.5))
T3 <- textGrob("3 Truths", gp = gpar(cex = 1.5))
xlab <- textGrob("Predicted Ranking", gp = gpar(cex = 2))
ylab <- textGrob("Observed Ranking", gp = gpar(cex = 2), rot = 90)
Tlab <- textGrob("Data Generated Using", gp = gpar(cex = 2), rot = 270)
Mlab <- textGrob("Model Assumption", gp = gpar(cex = 2))
blank <- textGrob("", gp = gpar(cex = 1.5))
grid.arrange(arrangeGrob(blank, blank, ylab, blank, nrow = 4, heights = c(0.2,
0.2, 3, 0.3)), arrangeGrob(arrangeGrob(blank, Mlab, blank, ncol = 3,
widths = c(0.3, 3, 0.1)), arrangeGrob(blank, T1, blank, T2, blank,
T3, ncol = 6, widths = c(0.15, 1, 0.15, 1, 0.15, 1)), arrangeGrob(postpred[[1]][[1]],
postpred[[1]][[2]], postpred[[1]][[3]], ncol = 3), arrangeGrob(postpred[[2]][[1]],
postpred[[2]][[2]], postpred[[2]][[3]], ncol = 3), arrangeGrob(postpred[[3]][[1]],
postpred[[3]][[2]], postpred[[3]][[3]], ncol = 3), arrangeGrob(blank,
xlab, blank, ncol = 3, widths = c(0.3, 3, 0.1)), nrow = 6, heights = c(0.2,
0.2, 1, 1, 1, 0.2)), arrangeGrob(blank, blank, T1, T2, T3, blank,
nrow = 6, heights = c(0.2, 0.2, 1, 1, 1, 0.3)), arrangeGrob(blank,
blank, Tlab, blank, nrow = 4, heights = c(0.2, 0.2, 3, 0.3)), ncol = 4,
widths = c(0.2, 2.8, 0.4, 0.2))
11 Graphs from JASP
Our lab at the University of Amsterdam has developed JASP, a free and open-source program for statistical analysis. In many ways, JASP is SPSS done right: minimalist output with progressive disclosure, dynamic updating of results, Bayesian analysis options, and, of course, clean graphs. Below is a series of JASP graphs.
11.1 Correlation Matrix
This multi-panel plot combines several elements that should now be familiar: correlation plots, histograms with density estimators, and, on the lower diagonal, the associated statistics.
Show R-Code.plotMarginalCor <- function(variable, cexYlab = 1.3, lwd = 2, rugs = FALSE) {
# histogram with density estimator
variable <- variable[!is.na(variable)]
density <- density(variable)
h <- hist(variable, plot = FALSE)
jitVar <- jitter(variable)
yhigh <- max(max(h$density), max(density$y))
ylow <- 0
xticks <- pretty(c(variable, h$breaks), min.n = 3)
plot(range(xticks), c(ylow, yhigh), type = "n", axes = FALSE, ylab = "",
xlab = "")
h <- hist(variable, freq = FALSE, main = "", ylim = c(ylow, yhigh), xlab = "",
ylab = " ", axes = FALSE, col = "grey", add = TRUE, nbreaks = round(length(variable)/5))
ax1 <- axis(1, line = 0.3, at = xticks, lab = xticks)
par(las = 0)
ax2 <- axis(2, at = c(0, max(max(h$density), max(density$y))/2, max(max(h$density),
max(density$y))), labels = c("", "Density", ""), lwd.ticks = 0,
pos = range(ax1) - 0.08 * diff(range(ax1)), cex.axis = 1.7, mgp = c(3,
0.7, 0))
if (rugs)
rug(jitVar)
lines(density$x[density$x >= min(ax1) & density$x <= max(ax1)], density$y[density$x >=
min(ax1) & density$x <= max(ax1)], lwd = lwd)
}
.poly.pred <- function(fit, line = FALSE, xMin, xMax, lwd) {
# predictions of fitted model
# create function formula
f <- vector("character", 0)
for (i in seq_along(coef(fit))) {
if (i == 1) {
temp <- paste(coef(fit)[[i]])
f <- paste(f, temp, sep = "")
}
if (i > 1) {
temp <- paste("(", coef(fit)[[i]], ")*", "x^", i - 1, sep = "")
f <- paste(f, temp, sep = "+")
}
}
x <- seq(xMin, xMax, length.out = 100)
predY <- eval(parse(text = f))
if (line == FALSE) {
return(predY)
}
if (line) {
lines(x, predY, lwd = lwd)
}
}
.plotScatter <- function(xVar, yVar, cexPoints = 1.3, cexXAxis = 1.3,
cexYAxis = 1.3, lwd = 2) {
# displays scatterplot
d <- data.frame(xx = xVar, yy = yVar)
d <- na.omit(d)
xVar <- d$xx
yVar <- d$yy
fit <- lm(yy ~ poly(xx, 1, raw = TRUE), d)
xlow <- min((min(xVar) - 0.1 * min(xVar)), min(pretty(xVar)))
xhigh <- max((max(xVar) + 0.1 * max(xVar)), max(pretty(xVar)))
xticks <- pretty(c(xlow, xhigh))
ylow <- min((min(yVar) - 0.1 * min(yVar)), min(pretty(yVar)), min(.poly.pred(fit,
line = FALSE, xMin = xticks[1], xMax = xticks[length(xticks)],
lwd = lwd)))
yhigh <- max((max(yVar) + 0.1 * max(yVar)), max(pretty(yVar)), max(.poly.pred(fit,
line = FALSE, xMin = xticks[1], xMax = xticks[length(xticks)],
lwd = lwd)))
yticks <- pretty(c(ylow, yhigh))
yLabs <- vector("character", length(yticks))
for (i in seq_along(yticks)) {
if (yticks[i] < 10^6) {
yLabs[i] <- format(yticks[i], digits = 3, scientific = FALSE)
} else {
yLabs[i] <- format(yticks[i], digits = 3, scientific = TRUE)
}
}
plot(xVar, yVar, col = "black", pch = 21, bg = "grey", ylab = "",
xlab = "", axes = FALSE, ylim = range(yticks), xlim = range(xticks),
cex = cexPoints)
.poly.pred(fit, line = TRUE, xMin = xticks[1], xMax = xticks[length(xticks)],
lwd = lwd)
par(las = 1)
axis(1, line = 0.4, labels = xticks, at = xticks, cex.axis = cexXAxis)
axis(2, line = 0.2, labels = yLabs, at = yticks, cex.axis = cexYAxis)
invisible(max(nchar(yLabs)))
}
.plotCorValue <- function(xVar, yVar, cexText = 2.5, cexCI = 1.7, hypothesis = "correlated",
pearson = TRUE, kendallsTauB = FALSE, spearman = FALSE, confidenceInterval = 0.95) {
# displays correlation value
CIPossible <- TRUE
tests <- c()
if (pearson)
tests <- c(tests, "pearson")
if (spearman)
tests <- c(tests, "spearman")
if (kendallsTauB)
tests <- c(tests, "kendall")
plot(1, 1, type = "n", axes = FALSE, ylab = "", xlab = "")
lab <- vector("list")
for (i in seq_along(tests)) {
if (round(cor.test(xVar, yVar, method = tests[i])$estimate, 8) ==
1) {
CIPossible <- FALSE
if (tests[i] == "pearson") {
lab[[i]] <- bquote(italic(r) == "1.000")
}
if (tests[i] == "spearman") {
lab[[i]] <- bquote(italic(rho) == "1.000")
}
if (tests[i] == "kendall") {
lab[[i]] <- bquote(italic(tau) == "1.000")
}
} else if (round(cor.test(xVar, yVar, method = tests[i])$estimate,
8) == -1) {
CIPossible <- FALSE
if (tests[i] == "pearson") {
lab[[i]] <- bquote(italic(r) == "-1.000")
}
if (tests[i] == "spearman") {
lab[[i]] <- bquote(italic(rho) == "-1.000")
}
if (tests[i] == "kendall") {
lab[[i]] <- bquote(italic(tau) == "-1.000")
}
} else {
if (tests[i] == "pearson") {
lab[[i]] <- bquote(italic(r) == .(formatC(round(cor.test(xVar,
yVar, method = tests[i])$estimate, 3), format = "f",
digits = 3)))
}
if (tests[i] == "spearman") {
lab[[i]] <- bquote(rho == .(formatC(round(cor.test(xVar,
yVar, method = tests[i])$estimate, 3), format = "f",
digits = 3)))
}
if (tests[i] == "kendall") {
lab[[i]] <- bquote(tau == .(formatC(round(cor.test(xVar,
yVar, method = tests[i])$estimate, 3), format = "f",
digits = 3)))
}
}
}
if (length(tests) == 1) {
ypos <- 1
}
if (length(tests) == 2) {
ypos <- c(1.1, 0.9)
}
if (length(tests) == 3) {
ypos <- c(1.2, 1, 0.8)
}
for (i in seq_along(tests)) {
text(1, ypos[i], labels = lab[[i]], cex = cexText)
}
if (hypothesis == "correlated" & length(tests) == 1 & any(tests ==
"pearson")) {
alternative <- "two.sided"
ctest <- cor.test(xVar, yVar, method = tests, conf.level = confidenceInterval)
}
if (hypothesis != "correlated" & length(tests) == 1 & any(tests ==
"pearson")) {
if (hypothesis == "correlatedPositively") {
ctest <- cor.test(xVar, yVar, method = tests, alternative = "greater",
conf.level = confidenceInterval)
} else if (hypothesis == "correlatedNegatively") {
ctest <- cor.test(xVar, yVar, method = tests, alternative = "less",
conf.level = confidenceInterval)
}
}
if (any(tests == "pearson") & length(tests) == 1 && CIPossible) {
CIlow <- formatC(round(ctest$conf.int[1], 3), format = "f", digits = 3)
CIhigh <- formatC(round(ctest$conf.int[2], 3), format = "f", digits = 3)
text(1, 0.8, labels = paste(100 * confidenceInterval, "% CI: [",
CIlow, ", ", CIhigh, "]", sep = ""), cex = cexCI)
}
}
### matrix plot ###
dataset <- read.csv("obk.long_correct.csv")
variables <- c("pre.2", "pre.3", "pre.5", "post.3", "post.5")
l <- length(variables)
par(mfrow = c(l, l), cex.axis = 1.3, mar = c(3, 4, 2, 1.5) + 0.1, oma = c(0,
2.2, 2, 0))
for (row in seq_len(l)) {
for (col in seq_len(l)) {
if (row == col) {
.plotMarginalCor(dataset[[variables[row]]]) # plot marginal (histogram with density estimator)
}
if (col > row) {
.plotScatter(dataset[[variables[col]]], dataset[[variables[row]]]) # plot scatterplot
}
if (col < row) {
if (l < 7) {
.plotCorValue(dataset[[variables[col]]], dataset[[variables[row]]],
cexCI = 1.2) # plot r= ...
}
if (l >= 7) {
.plotCorValue(dataset[[variables[col]]], dataset[[variables[row]]],
cexCI = 1.2)
}
}
}
}
textpos <- seq(1/(l * 2), (l * 2 - 1)/(l * 2), 2/(l * 2))
for (t in seq_along(textpos)) {
mtext(text = variables[t], side = 3, outer = TRUE, at = textpos[t],
cex = 1.9, line = -0.8)
mtext(text = variables[t], side = 2, outer = TRUE, at = rev(textpos)[t],
cex = 1.9, line = -0.1)
}
11.2 Prior and Posterior
This is one of our favorite JASP graphs. Note the balance between the graphical elements. When it comes to inference about the equality of two means (which is the JASP analysis that yields this plot), this graph provides: (1) the prior distribution of effect size; (2) the posterior distribution of effect size; (3) the 95% credible interval; (4) the posterior median;(5) the Bayes factor; (6) a Savage-Dickey visualization of the Bayes factor by means of the height ratio for the grey dots shown at an effect size of zero; (7) a pizza plot visualization of the Bayes factor. That’s a lot of information, but the graph is still relatively clean.
Show R-Codelibrary(plotrix)
.likelihoodShiftedT <- function(par, data) {
-sum(log(dt((data - par[1])/par[2], par[3])/par[2]))
}
.dposteriorShiftedT <- function(x, parameters, oneSided) {
# function that returns the posterior density
if (oneSided == FALSE) {
dt((x - parameters[1])/parameters[2], parameters[3])/parameters[2]
} else if (oneSided == "right") {
ifelse(x >= 0, (dt((x - parameters[1])/parameters[2], parameters[3])/parameters[2])/pt((0 -
parameters[1])/parameters[2], parameters[3], lower.tail = FALSE),
0)
} else if (oneSided == "left") {
ifelse(x <= 0, (dt((x - parameters[1])/parameters[2], parameters[3])/parameters[2])/pt((0 -
parameters[1])/parameters[2], parameters[3], lower.tail = TRUE),
0)
}
}
.dprior <- function(x, r, oneSided = oneSided) {
# function that returns the prior density
if (oneSided == "right") {
y <- ifelse(x < 0, 0, 2/(pi * r * (1 + (x/r)^2)))
return(y)
}
if (oneSided == "left") {
y <- ifelse(x > 0, 0, 2/(pi * r * (1 + (x/r)^2)))
return(y)
} else {
return(1/(pi * r * (1 + (x/r)^2)))
}
}
.plotPosterior.ttest <- function(x = NULL, y = NULL, paired = FALSE, oneSided = FALSE,
BF, BFH1H0 = TRUE, iterations = 10000, rscale = "medium", lwd = 2,
cexPoints = 1.5, cexAxis = 1.2, cexYlab = 1.5, cexXlab = 1.5, cexTextBF = 1.4,
cexCI = 1.1, cexLegend = 1.2, lwdAxis = 1.2, addInformation = TRUE,
dontPlotData = FALSE) {
if (addInformation) {
par(mar = c(5.6, 5, 7, 4) + 0.1, las = 1)
} else {
par(mar = c(5.6, 5, 4, 4) + 0.1, las = 1)
}
if (dontPlotData) {
plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE,
xlab = "", ylab = "")
axis(1, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis,
xlab = "")
axis(2, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis,
ylab = "")
mtext(text = "Density", side = 2, las = 0, cex = cexYlab, line = 3.25)
mtext(expression(paste("Effect size", ~delta)), side = 1, cex = cexXlab,
line = 2.5)
return()
}
if (rscale == "medium") {
r <- sqrt(2)/2
}
if (rscale == "wide") {
r <- 1
}
if (rscale == "ultrawide") {
r <- sqrt(2)
}
if (mode(rscale) == "numeric") {
r <- rscale
}
if (oneSided == FALSE) {
nullInterval <- NULL
}
if (oneSided == "right") {
nullInterval <- c(0, Inf)
}
if (oneSided == "left") {
nullInterval <- c(-Inf, 0)
}
# sample from delta posterior
samples <- BayesFactor::ttestBF(x = x, y = y, paired = paired, posterior = TRUE,
iterations = iterations, rscale = r)
delta <- samples[, "delta"]
# fit shifted t distribution
if (is.null(y)) {
deltaHat <- mean(x)/sd(x)
N <- length(x)
df <- N - 1
sigmaStart <- 1/N
} else if (paired) {
deltaHat <- mean(x - y)/sd(x - y)
N <- length(x)
df <- N - 1
sigmaStart <- 1/N
} else if (!is.null(y) && !paired) {
N1 <- length(x)
N2 <- length(y)
sdPooled <- sqrt(((N1 - 1) * var(x) + (N2 - 1) * var(y))/(N1 +
N2))
deltaHat <- (mean(x) - mean(y))/sdPooled
df <- N1 + N2 - 2
sigmaStart <- sqrt(N1 * N2/(N1 + N2))
}
if (sigmaStart < 0.01)
sigmaStart <- 0.01
parameters <- try(silent = TRUE, expr = optim(par = c(deltaHat, sigmaStart,
df), fn = .likelihoodShiftedT, data = delta, method = "BFGS")$par)
if (class(parameters) == "try-error") {
parameters <- try(silent = TRUE, expr = optim(par = c(deltaHat,
sigmaStart, df), fn = .likelihoodShiftedT, data = delta, method = "Nelder-Mead")$par)
}
if (BFH1H0) {
BF10 <- BF
BF01 <- 1/BF10
} else {
BF01 <- BF
BF10 <- 1/BF01
}
# set limits plot
xlim <- vector("numeric", 2)
if (oneSided == FALSE) {
xlim[1] <- min(-2, quantile(delta, probs = 0.01)[[1]])
xlim[2] <- max(2, quantile(delta, probs = 0.99)[[1]])
if (length(x) < 10) {
if (addInformation) {
stretch <- 1.52
} else {
stretch <- 1.4
}
} else {
stretch <- 1.2
}
}
if (oneSided == "right") {
# if (length(delta[delta >= 0]) < 10) return('Plotting is not
# possible: To few posterior samples in tested interval')
xlim[1] <- min(-2, quantile(delta[delta >= 0], probs = 0.01)[[1]])
xlim[2] <- max(2, quantile(delta[delta >= 0], probs = 0.99)[[1]])
if (any(is.na(xlim))) {
xlim[1] <- min(-2, .qShiftedT(0.01, parameters, oneSided = "right"))
xlim[2] <- max(2, .qShiftedT(0.99, parameters, oneSided = "right"))
}
stretch <- 1.32
}
if (oneSided == "left") {
# if (length(delta[delta <= 0]) < 10) return('Plotting is not
# possible: To few posterior samples in tested interval')
xlim[1] <- min(-2, quantile(delta[delta <= 0], probs = 0.01)[[1]])
xlim[2] <- max(2, quantile(delta[delta <= 0], probs = 0.99)[[1]])
if (any(is.na(xlim))) {
xlim[1] <- min(-2, .qShiftedT(0.01, parameters, oneSided = "left"))
xlim[2] <- max(2, .qShiftedT(0.99, parameters, oneSided = "left"))
}
stretch <- 1.32
}
xticks <- pretty(xlim)
ylim <- vector("numeric", 2)
ylim[1] <- 0
dmax <- optimize(function(x) .dposteriorShiftedT(x, parameters = parameters,
oneSided = oneSided), interval = range(xticks), maximum = TRUE)$objective
ylim[2] <- max(stretch * .dprior(0, r, oneSided = oneSided), stretch *
dmax) # get maximum density
# calculate position of 'nice' tick marks and create labels
yticks <- pretty(ylim)
xlabels <- formatC(xticks, 1, format = "f")
ylabels <- formatC(yticks, 1, format = "f")
# compute 95% credible interval & median:
if (oneSided == FALSE) {
CIlow <- quantile(delta, probs = 0.025)[[1]]
CIhigh <- quantile(delta, probs = 0.975)[[1]]
medianPosterior <- median(delta)
if (any(is.na(c(CIlow, CIhigh, medianPosterior)))) {
CIlow <- .qShiftedT(0.025, parameters, oneSided = FALSE)
CIhigh <- .qShiftedT(0.975, parameters, oneSided = FALSE)
medianPosterior <- .qShiftedT(0.5, parameters, oneSided = FALSE)
}
}
if (oneSided == "right") {
CIlow <- quantile(delta[delta >= 0], probs = 0.025)[[1]]
CIhigh <- quantile(delta[delta >= 0], probs = 0.975)[[1]]
medianPosterior <- median(delta[delta >= 0])
if (any(is.na(c(CIlow, CIhigh, medianPosterior)))) {
CIlow <- .qShiftedT(0.025, parameters, oneSided = "right")
CIhigh <- .qShiftedT(0.975, parameters, oneSided = "right")
medianPosterior <- .qShiftedT(0.5, parameters, oneSided = "right")
}
}
if (oneSided == "left") {
CIlow <- quantile(delta[delta <= 0], probs = 0.025)[[1]]
CIhigh <- quantile(delta[delta <= 0], probs = 0.975)[[1]]
medianPosterior <- median(delta[delta <= 0])
if (any(is.na(c(CIlow, CIhigh, medianPosterior)))) {
CIlow <- .qShiftedT(0.025, parameters, oneSided = "left")
CIhigh <- .qShiftedT(0.975, parameters, oneSided = "left")
medianPosterior <- .qShiftedT(0.5, parameters, oneSided = "left")
}
}
posteriorLine <- .dposteriorShiftedT(x = seq(min(xticks), max(xticks),
length.out = 1000), parameters = parameters, oneSided = oneSided)
xlim <- c(min(CIlow, range(xticks)[1]), max(range(xticks)[2], CIhigh))
plot(1, 1, xlim = xlim, ylim = range(yticks), ylab = "", xlab = "",
type = "n", axes = FALSE)
lines(seq(min(xticks), max(xticks), length.out = 1000), posteriorLine,
lwd = lwd)
lines(seq(min(xticks), max(xticks), length.out = 1000), .dprior(seq(min(xticks),
max(xticks), length.out = 1000), r = r, oneSided = oneSided),
lwd = lwd, lty = 3)
axis(1, at = xticks, labels = xlabels, cex.axis = cexAxis, lwd = lwdAxis)
axis(2, at = yticks, labels = ylabels, , cex.axis = cexAxis, lwd = lwdAxis)
if (nchar(ylabels[length(ylabels)]) > 4) {
mtext(text = "Density", side = 2, las = 0, cex = cexYlab, line = 4)
} else if (nchar(ylabels[length(ylabels)]) == 4) {
mtext(text = "Density", side = 2, las = 0, cex = cexYlab, line = 3.25)
} else if (nchar(ylabels[length(ylabels)]) < 4) {
mtext(text = "Density", side = 2, las = 0, cex = cexYlab, line = 2.85)
}
mtext(expression(paste("Effect size", ~delta)), side = 1, cex = cexXlab,
line = 2.5)
points(0, .dprior(0, r, oneSided = oneSided), col = "black", pch = 21,
bg = "grey", cex = cexPoints)
if (oneSided == FALSE) {
heightPosteriorAtZero <- .dposteriorShiftedT(0, parameters = parameters,
oneSided = oneSided)
} else if (oneSided == "right") {
posteriorLineLargerZero <- posteriorLine[posteriorLine > 0]
heightPosteriorAtZero <- posteriorLineLargerZero[1]
} else if (oneSided == "left") {
posteriorLineLargerZero <- posteriorLine[posteriorLine > 0]
heightPosteriorAtZero <- posteriorLineLargerZero[length(posteriorLineLargerZero)]
}
points(0, heightPosteriorAtZero, col = "black", pch = 21, bg = "grey",
cex = cexPoints)
### 95% credible interval
# enable plotting in margin
par(xpd = TRUE)
yCI <- grconvertY(dmax, "user", "ndc") + 0.04
yCI <- grconvertY(yCI, "ndc", "user")
arrows(CIlow, yCI, CIhigh, yCI, angle = 90, code = 3, length = 0.1,
lwd = lwd)
medianText <- formatC(medianPosterior, digits = 3, format = "f")
if (addInformation) {
# display BF10 value
offsetTopPart <- 0.06
yy <- grconvertY(0.75 + offsetTopPart, "ndc", "user")
yy2 <- grconvertY(0.806 + offsetTopPart, "ndc", "user")
xx <- min(xticks)
if (BF10 >= 1000000 | BF01 >= 1000000) {
BF10t <- formatC(BF10, 3, format = "e")
BF01t <- formatC(BF01, 3, format = "e")
}
if (BF10 < 1000000 & BF01 < 1000000) {
BF10t <- formatC(BF10, 3, format = "f")
BF01t <- formatC(BF01, 3, format = "f")
}
if (oneSided == FALSE) {
text(xx, yy2, bquote(BF[10] == .(BF10t)), cex = cexTextBF,
pos = 4)
text(xx, yy, bquote(BF[0][1] == .(BF01t)), cex = cexTextBF,
pos = 4)
}
if (oneSided == "right") {
text(xx, yy2, bquote(BF["+"][0] == .(BF10t)), cex = cexTextBF,
pos = 4)
text(xx, yy, bquote(BF[0]["+"] == .(BF01t)), cex = cexTextBF,
pos = 4)
}
if (oneSided == "left") {
text(xx, yy2, bquote(BF["-"][0] == .(BF10t)), cex = cexTextBF,
pos = 4)
text(xx, yy, bquote(BF[0]["-"] == .(BF01t)), cex = cexTextBF,
pos = 4)
}
yy <- grconvertY(0.756 + offsetTopPart, "ndc", "user")
yy2 <- grconvertY(0.812 + offsetTopPart, "ndc", "user")
CIText <- paste("95% CI: [", bquote(.(formatC(CIlow, 3, format = "f"))),
", ", bquote(.(formatC(CIhigh, 3, format = "f"))), "]", sep = "")
medianLegendText <- paste("median =", medianText)
text(max(xticks), yy2, medianLegendText, cex = 1.1, pos = 2)
text(max(xticks), yy, CIText, cex = 1.1, pos = 2)
# probability wheel
if (max(nchar(BF10t), nchar(BF01t)) <= 4) {
xx <- grconvertX(0.44, "ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 5) {
xx <- grconvertX(0.44 + 0.001 * 5, "ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 6) {
xx <- grconvertX(0.44 + 0.001 * 6, "ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 7) {
xx <- grconvertX(0.44 + 0.002 * max(nchar(BF10t), nchar(BF01t)),
"ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 8) {
xx <- grconvertX(0.44 + 0.003 * max(nchar(BF10t), nchar(BF01t)),
"ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) > 8) {
xx <- grconvertX(0.44 + 0.005 * max(nchar(BF10t), nchar(BF01t)),
"ndc", "user")
}
yy <- grconvertY(0.788 + offsetTopPart, "ndc", "user")
# make sure that colored area is centered
radius <- 0.06 * diff(range(xticks))
A <- radius^2 * pi
alpha <- 2/(BF01 + 1) * A/radius^2
startpos <- pi/2 - alpha/2
# draw probability wheel
plotrix::floating.pie(xx, yy, c(BF10, 1), radius = radius, col = c("darkred",
"white"), lwd = 2, startpos = startpos)
yy <- grconvertY(0.865 + offsetTopPart, "ndc", "user")
yy2 <- grconvertY(0.708 + offsetTopPart, "ndc", "user")
if (oneSided == FALSE) {
text(xx, yy, "data|H1", cex = cexCI)
text(xx, yy2, "data|H0", cex = cexCI)
}
if (oneSided == "right") {
text(xx, yy, "data|H+", cex = cexCI)
text(xx, yy2, "data|H0", cex = cexCI)
}
if (oneSided == "left") {
text(xx, yy, "data|H-", cex = cexCI)
text(xx, yy2, "data|H0", cex = cexCI)
}
# add legend
CIText <- paste("95% CI: [", bquote(.(formatC(CIlow, 3, format = "f"))),
" ; ", bquote(.(formatC(CIhigh, 3, format = "f"))), "]", sep = "")
medianLegendText <- paste("median =", medianText)
}
mostPosterior <- mean(delta > mean(range(xticks)))
if (mostPosterior >= 0.5) {
legendPosition <- min(xticks)
legend(legendPosition, max(yticks), legend = c("Posterior", "Prior"),
lty = c(1, 3), bty = "n", lwd = c(lwd, lwd), cex = cexLegend,
xjust = 0, yjust = 1, x.intersp = 0.6, seg.len = 1.2)
} else {
legendPosition <- max(xticks)
legend(legendPosition, max(yticks), legend = c("Posterior", "Prior"),
lty = c(1, 3), bty = "n", lwd = c(lwd, lwd), cex = cexLegend,
xjust = 1, yjust = 1, x.intersp = 0.6, seg.len = 1.2)
}
}
### generate data ###
set.seed(1)
x <- rnorm(30, 0.15)
### calculate Bayes factor ###
library(BayesFactor)
BF <- extractBF(ttestBF(x, rscale = "medium"), onlybf = TRUE)
### plot ###
.plotPosterior.ttest(x = x, rscale = "medium", BF = BF)
11.3 Robustness Check
This JASP graph shows the results of a Bayes factor robustness check. Note the second y-axis, the balance of the graphical elements, and the font size.
Show R-Codelibrary(BayesFactor)
.plotBF.robustnessCheck.ttest <- function(x = NULL, y = NULL, paired = FALSE,
BF10post, formula = NULL, data = NULL, rscale = 1, oneSided = FALSE,
lwd = 2, cexPoints = 1.4, cexAxis = 1.2, cexYXlab = 1.5, cexText = 1.2,
cexLegend = 1.4, lwdAxis = 1.2, cexEvidence = 1.6, BFH1H0 = TRUE,
dontPlotData = FALSE) {
#### settings ####
if (rscale == "medium") {
r <- sqrt(2)/2
}
if (rscale == "wide") {
r <- 1
}
if (rscale == "ultrawide") {
r <- sqrt(2)
}
if (mode(rscale) == "numeric") {
r <- rscale
}
if (oneSided == FALSE) {
nullInterval <- NULL
}
if (oneSided == "right") {
nullInterval <- c(0, Inf)
}
if (oneSided == "left") {
nullInterval <- c(-Inf, 0)
}
par(mar = c(5, 6, 6, 7) + 0.1, las = 1)
if (dontPlotData) {
plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE,
xlab = "", ylab = "")
axis(1, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis,
xlab = "")
axis(2, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis,
ylab = "")
if (oneSided == FALSE) {
if (BFH1H0) {
mtext(text = expression(BF[1][0]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
} else {
mtext(text = expression(BF[0][1]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
}
}
if (oneSided == "right") {
if (BFH1H0) {
mtext(text = expression(BF["+"][0]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["+"]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
}
}
if (oneSided == "left") {
if (BFH1H0) {
mtext(text = expression(BF["-"][0]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["-"]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
}
}
mtext("Cauchy prior width", side = 1, cex = cexYXlab, line = 2.5)
return()
}
#### get BFs ###
rValues <- seq(0.0005, 1.5, length.out = 400)
# BF10
BF10 <- vector("numeric", length(rValues))
for (i in seq_along(rValues)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = x, y = y, paired = paired,
nullInterval = nullInterval, rscale = rValues[i])
BF10[i] <- BayesFactor::extractBF(BF, logbf = FALSE, onlybf = F)[1,
"bf"]
} else {
BF10[i] <- .oneSidedTtestBFRichard(x = x, y = y, paired = paired,
oneSided = oneSided, r = rValues[i])
}
}
# BF10 'medium' prior
if (oneSided == FALSE) {
BF10m <- BayesFactor::ttestBF(x = x, y = y, paired = paired, nullInterval = nullInterval,
rscale = "medium")
BF10m <- BayesFactor::extractBF(BF10m, logbf = FALSE, onlybf = F)[1,
"bf"]
} else {
BF10m <- .oneSidedTtestBFRichard(x = x, y = y, paired = paired,
oneSided = oneSided, r = "medium")
}
BF10mText <- BF10m
# BF10 'wide' prior
if (oneSided == FALSE) {
BF10w <- BayesFactor::ttestBF(x = x, y = y, paired = paired, nullInterval = nullInterval,
rscale = "wide")
BF10w <- BayesFactor::extractBF(BF10w, logbf = FALSE, onlybf = F)[1,
"bf"]
} else {
BF10w <- .oneSidedTtestBFRichard(x = x, y = y, paired = paired,
oneSided = oneSided, r = "wide")
}
BF10wText <- BF10w
# BF10 'ultrawide' prior
if (oneSided == FALSE) {
BF10ultra <- BayesFactor::ttestBF(x = x, y = y, paired = paired,
nullInterval = nullInterval, rscale = "ultrawide")
BF10ultra <- BayesFactor::extractBF(BF10ultra, logbf = FALSE,
onlybf = F)[1, "bf"]
} else {
BF10ultra <- .oneSidedTtestBFRichard(x = x, y = y, paired = paired,
oneSided = oneSided, r = "ultrawide")
}
BF10ultraText <- BF10ultra
# BF10 user prior
BF10user <- BF10post
BF10userText <- BF10user
####################### scale y axis ###########################
BF <- c(BF10, BF10m, BF10w, BF10ultra, BF10user)
if (!BFH1H0) {
BF <- 1/BF
BF10 <- 1/BF10
BF10m <- 1/BF10m
BF10w <- 1/BF10w
BF10ultra <- 1/BF10ultra
# BF10user <- 1 / BF10user
}
# y-axis labels larger than 1
y1h <- "1"
i <- 1
while (eval(parse(text = y1h[i])) < max(BF10)) {
if (grepl(pattern = "e", y1h[i])) {
newy <- paste(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y1h[i], "0", sep = "")
}
if (eval(parse(text = newy)) >= 10^6) {
newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
}
y1h <- c(y1h, newy)
i <- i + 1
}
y3h <- "3"
i <- 1
while (eval(parse(text = y3h[i])) < max(BF10)) {
if (grepl(pattern = "e", y3h[i])) {
newy <- paste(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y3h[i], "0", sep = "")
}
if (as.numeric(newy) >= 10^6) {
newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
}
y3h <- c(y3h, newy)
i <- i + 1
}
yhigh <- vector("numeric", length(y1h) + length(y3h))
o <- 1
e <- 1
for (i in seq_along(yhigh)) {
if (i%%2 == 1) {
yhigh[i] <- y1h[o]
o <- o + 1
}
if (i%%2 == 0) {
yhigh[i] <- y3h[e]
e <- e + 1
}
}
yhighLab <- as.character(yhigh)
# y-axis labels smaller than 1
y1l <- "1/1"
i <- 1
while (eval(parse(text = y1l[i])) > min(BF10)) {
if (grepl(pattern = "e", y1l[i])) {
newy <- paste(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y1l[i], "0", sep = "")
}
if (eval(parse(text = newy)) <= 10^(-6)) {
newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
newy <- sub("-", "+", x = newy)
newy <- paste0("1/", newy)
}
y1l <- c(y1l, newy)
i <- i + 1
}
y3l <- "1/3"
i <- 1
while (eval(parse(text = y3l[i])) > min(BF10)) {
if (grepl(pattern = "e", y3l[i])) {
newy <- paste(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y3l[i], "0", sep = "")
}
if (newy == "1/3e+9") {
newy <- "1/3e+09"
}
if (eval(parse(text = newy)) <= 10^(-6) & eval(parse(text = newy)) >
10^(-9)) {
newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
newy <- paste(substring(newy, 1, nchar(newy) - 1), as.numeric(substring(newy,
nchar(newy), nchar(newy))) - 1, sep = "")
newy <- sub(".33", "", newy)
newy <- sub("-", "+", x = newy)
newy <- paste0("1/", newy)
}
y3l <- c(y3l, newy)
i <- i + 1
}
ylow <- vector("numeric", length(y1l) + length(y3l))
o <- 1
e <- 1
for (i in seq_along(ylow)) {
if (i%%2 == 1) {
ylow[i] <- y1l[o]
o <- o + 1
}
if (i%%2 == 0) {
ylow[i] <- y3l[e]
e <- e + 1
}
}
yLab <- c(rev(ylow[-1]), yhighLab)
# remove 3's if yLab vector is too long
omit3s <- FALSE
if (length(yLab) > 9) {
omit3s <- TRUE
ind <- which(yLab == "3")
yLabsHigh <- yLab[ind:length(yLab)]
if (length(yLabsHigh) > 1) {
yLabsHigh <- yLabsHigh[seq(2, length(yLabsHigh), 2)]
} else {
yLabsHigh <- character(0)
}
yLabsLow <- yLab[1:(ind - 1)]
yLabsLow <- yLabsLow[-grep(pattern = "/3", x = yLab)]
yLab1s <- c(yLabsLow, yLabsHigh)
if (max(BF10) > eval(parse(text = yLab1s[length(yLab1s)]))) {
for (i in 1:2) {
if (grepl(pattern = "e", yLab1s[length(yLab1s)])) {
newy <- paste(strsplit(yLab1s[length(yLab1s)], split = "+",
fixed = TRUE)[[1]][1], "+", as.numeric(strsplit(yLab1s[length(yLab1s)],
split = "+", fixed = TRUE)[[1]][2]) + 1, sep = "")
} else {
newy <- paste(yLab1s[length(yLab1s)], "0", sep = "")
}
if (eval(parse(text = newy)) >= 10^6) {
newy <- format(eval(parse(text = newy)), digits = 3,
scientific = TRUE)
}
yLab1s <- c(yLab1s, newy)
}
}
if (max(BF10) > eval(parse(text = yLab1s[length(yLab1s) - 1]))) {
if (grepl(pattern = "e", yLab1s[length(yLab1s)])) {
newy <- paste(strsplit(yLab1s[length(yLab1s)], split = "+",
fixed = TRUE)[[1]][1], "+", as.numeric(strsplit(yLab1s[length(yLab1s)],
split = "+", fixed = TRUE)[[1]][2]) + 1, sep = "")
} else {
newy <- paste(yLab1s[length(yLab1s)], "0", sep = "")
}
if (eval(parse(text = newy)) >= 10^6) {
newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
}
yLab1s <- c(yLab1s, newy)
}
if (yLab1s[1] == "1") {
yLab1s <- c(paste0(yLab1s[1], "/", "10"), yLab1s)
}
if (yLab1s[length(yLab1s)] == "1") {
yLab1s <- c(yLab1s, "10")
}
if (min(BF10) < eval(parse(text = yLab1s[1]))) {
for (i in 1:2) {
if (grepl(pattern = "e", yLab1s[1])) {
newy <- paste(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(yLab1s[1], "0", sep = "")
}
if (eval(parse(text = newy)) <= 10^(-6)) {
newy <- format(eval(parse(text = newy)), digits = 3,
scientific = TRUE)
newy <- sub("-", "+", x = newy)
newy <- substring(newy, nchar(newy) - 4, nchar(newy))
newy <- paste0("1/", newy)
}
}
yLab1s <- c(newy, yLab1s)
}
if (min(BF10) < eval(parse(text = yLab1s[2]))) {
if (grepl(pattern = "e", yLab1s[1])) {
newy <- paste(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(yLab1s[1], "0", sep = "")
}
if (eval(parse(text = newy)) <= 10^(-6)) {
newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
newy <- sub("-", "+", x = newy)
newy <- substring(newy, nchar(newy) - 4, nchar(newy))
newy <- paste0("1/", newy)
}
yLab1s <- c(newy, yLab1s)
}
yLab <- yLab1s
}
while (length(yLab) > 9) {
ind <- which(yLab == "1")
if (ind == 1) {
yLabLow <- character(0)
} else {
yLabLow <- yLab[1:(ind - 1)]
}
if (ind == length(yLab)) {
yLabHigh <- character(0)
} else {
yLabHigh <- yLab[(ind + 1):length(yLab)]
}
if (length(yLabLow) > 1) {
yLabLow <- yLabLow[seq(length(yLabLow) - 1, 1, -2)]
} else {
yLabLow <- yLabLow
}
if (length(yLabHigh) > 1) {
yLabHigh <- yLabHigh[seq(2, length(yLabHigh), 2)]
} else {
yLabHigh <- yLabHigh
}
if (length(yLabLow) == 1) {
yLabLow <- paste("1/", yLabHigh[1], sep = "")
}
if (length(yLabHigh) == 1) {
yLabHigh <- strsplit(x = yLabLow[1], "/", fixed = TRUE)[[1]][2]
}
yLab <- c(rev(yLabLow), "1", yLabHigh)
}
while (eval(parse(text = yLab[2])) > min(BF10)) {
interval <- as.numeric(strsplit(format(eval(parse(text = yLab[1])),
digits = 3, scientific = TRUE), "-", fixed = TRUE)[[1]][2]) -
as.numeric(strsplit(format(eval(parse(text = yLab[2])), digits = 3,
scientific = TRUE), "-", fixed = TRUE)[[1]][2])
pot <- as.numeric(strsplit(format(eval(parse(text = yLab[1])),
digits = 3, scientific = TRUE), "-", fixed = TRUE)[[1]][2]) +
interval
if (nchar(pot) == 1)
pot <- paste("0", pot, sep = "")
newy <- paste("1/1e", "+", pot, sep = "")
yLab <- c(newy, yLab)
}
while (eval(parse(text = yLab[length(yLab) - 1])) < max(BF10)) {
interval <- as.numeric(strsplit(format(eval(parse(text = yLab[length(yLab)])),
digits = 3, scientific = TRUE), "+", fixed = TRUE)[[1]][2]) -
as.numeric(strsplit(format(eval(parse(text = yLab[length(yLab) -
1])), digits = 3, scientific = TRUE), "+", fixed = TRUE)[[1]][2])
pot <- as.numeric(strsplit(format(eval(parse(text = yLab[length(yLab)])),
digits = 3, scientific = TRUE), "+", fixed = TRUE)[[1]][2]) +
interval
if (nchar(pot) == 1)
pot <- paste("0", pot, sep = "")
newy <- paste(strsplit(format(eval(parse(text = yLab[length(yLab)])),
digits = 3, scientific = TRUE), "+", fixed = TRUE)[[1]][1],
"+", pot, sep = "")
yLab <- c(yLab, newy)
}
yAt <- vector("numeric", length(yLab))
for (i in seq_along(yLab)) {
yAt[i] <- log(eval(parse(text = yLab[i])))
}
####################### plot ###########################
xLab <- c(0, 0.25, 0.5, 0.75, 1, 1.25, 1.5)
xlim <- range(xLab)
ylow <- log(eval(parse(text = yLab[1])))
yhigh <- log(eval(parse(text = yLab[length(yLab)])))
ylim <- c(ylow, yhigh)
plot(1, 1, xlim = xlim, ylim = ylim, ylab = "", xlab = "", type = "n",
axes = FALSE)
for (i in seq_along(yAt)) {
lines(x = xlim, y = rep(yAt[i], 2), col = "darkgrey", lwd = 1.3,
lty = 2)
}
lines(xlim, rep(0, 2), lwd = lwd)
axis(1, at = xLab, labels = xLab, cex.axis = cexAxis, lwd = lwdAxis)
axis(2, at = yAt, labels = yLab, cex.axis = cexAxis, lwd = lwdAxis)
# enable plotting in margin
par(xpd = TRUE)
xx <- grconvertX(0.79, "ndc", "user")
yAthigh <- yAt[yAt >= 0]
if (!omit3s & eval(parse(text = yLab[1])) >= 1/300 & eval(parse(text = yLab[length(yLab)])) <=
300) {
for (i in 1:(length(yAthigh) - 1)) {
yy <- mean(c(yAthigh[i], yAthigh[i + 1]))
if (yAthigh[i] == log(1)) {
text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(3)) {
text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(10)) {
text(x = xx, yy, "Strong", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(30)) {
text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(100)) {
text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
}
}
yAtlow <- rev(yAt[yAt <= 0])
for (i in 1:(length(yAtlow) - 1)) {
yy <- mean(c(yAtlow[i], yAtlow[i + 1]))
if (yAtlow[i] == log(1)) {
text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/3)) {
text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/10)) {
text(x = xx, yy, "Strong", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/30)) {
text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/100)) {
text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
}
}
axis(side = 4, at = yAt, tick = TRUE, las = 2, cex.axis = cexAxis,
lwd = lwdAxis, labels = FALSE, line = -0.6)
xx <- grconvertX(0.96, "ndc", "user")
yy <- grconvertY(0.5, "npc", "user")
text(xx, yy, "Evidence", srt = -90, cex = cexEvidence)
}
if (omit3s) {
if (eval(parse(text = yLab[1])) <= 1/10^6) {
line <- 4.75
} else {
line <- 4.3
}
if (oneSided == FALSE) {
if (BFH1H0) {
mtext(text = expression(BF[1][0]), side = 2, las = 0,
cex = cexYXlab, line = line)
} else {
mtext(text = expression(BF[0][1]), side = 2, las = 0,
cex = cexYXlab, line = line)
}
}
if (oneSided == "right") {
if (BFH1H0) {
mtext(text = expression(BF["+"][0]), side = 2, las = 0,
cex = cexYXlab, line = line)
} else {
mtext(text = expression(BF[0]["+"]), side = 2, las = 0,
cex = cexYXlab, line = line)
}
}
if (oneSided == "left") {
if (BFH1H0) {
mtext(text = expression(BF["-"][0]), side = 2, las = 0,
cex = cexYXlab, line = line)
} else {
mtext(text = expression(BF[0]["-"]), side = 2, las = 0,
cex = cexYXlab, line = line)
}
}
}
if (omit3s == FALSE) {
if (oneSided == FALSE) {
if (BFH1H0) {
mtext(text = expression(BF[1][0]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
} else {
mtext(text = expression(BF[0][1]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
}
}
if (oneSided == "right") {
if (BFH1H0) {
mtext(text = expression(BF["+"][0]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["+"]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
}
}
if (oneSided == "left") {
if (BFH1H0) {
mtext(text = expression(BF["-"][0]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["-"]), side = 2, las = 0,
cex = cexYXlab, line = 3.1)
}
}
}
mtext("Cauchy prior width", side = 1, cex = cexYXlab, line = 2.5)
xx <- grconvertX(0.1, "npc", "user")
yy1 <- yAt[length(yAt) - 1]
yy2 <- yAt[length(yAt)]
yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
xxt <- grconvertX(0.28, "npc", "user")
if (oneSided == FALSE) {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
}
}
if (oneSided == "right") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
}
}
if (oneSided == "left") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
}
}
yy1 <- yAt[2]
yy2 <- yAt[1]
yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
if (oneSided == FALSE) {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1",
cex = cexText)
}
}
if (oneSided == "right") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+",
cex = cexText)
}
}
if (oneSided == "left") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-",
cex = cexText)
}
}
# display BF10
lines(rValues, log(BF10), col = "black", lwd = 2.7)
# display 'wide', user, and 'ultrawide' prior BFs
points(r, log(BF10user), pch = 21, bg = "grey", cex = cexPoints, lwd = 1.3) # user prior
points(1, log(BF10w), pch = 21, bg = "black", cex = 1.1, lwd = 1.3) # 'wide' prior
points(sqrt(2), log(BF10ultra), pch = 21, bg = "white", cex = 1.1,
lwd = 1.3) # 'ultrawide' prior
#### add legend BF values
# BFuser
if (BFH1H0) {
BF01userText <- 1/BF10userText
} else {
BF10userText <- 1/BF10userText
BF01userText <- 1/BF10userText
}
if (BF10userText >= 1000000 | BF01userText >= 1000000) {
BF10usert <- format(BF10userText, digits = 4, scientific = TRUE)
BF01usert <- format(BF01userText, digits = 4, scientific = TRUE)
}
if (BF10userText < 1000000 & BF01userText < 1000000) {
BF10usert <- formatC(BF10userText, 3, format = "f")
BF01usert <- formatC(BF01userText, 3, format = "f")
}
if (oneSided == FALSE) {
if (BF10userText >= BF01userText) {
userBF <- bquote(BF[10] == .(BF10usert))
} else {
userBF <- bquote(BF[0][1] == .(BF01usert))
}
}
if (oneSided == "right") {
if (BF10userText >= BF01userText) {
userBF <- bquote(BF["+"][0] == .(BF10usert))
} else {
userBF <- bquote(BF[0]["+"] == .(BF01usert))
}
}
if (oneSided == "left") {
if (BF10userText >= BF01userText) {
userBF <- bquote(BF["-"][0] == .(BF10usert))
} else {
userBF <- bquote(BF[0]["-"] == .(BF01usert))
}
}
# BFwide
BF01wText <- 1/BF10wText
if (BF10wText >= 1000000 | BF01wText >= 1000000) {
BF10wt <- format(BF10wText, digits = 4, scientific = TRUE)
BF01wt <- format(BF01wText, digits = 4, scientific = TRUE)
}
if (BF10wText < 1000000 & BF01wText < 1000000) {
BF10wt <- formatC(BF10wText, 3, format = "f")
BF01wt <- formatC(BF01wText, 3, format = "f")
}
if (oneSided == FALSE) {
if (BF10wText >= BF01wText) {
wBF <- bquote(BF[10] == .(BF10wt))
} else {
wBF <- bquote(BF[0][1] == .(BF01wt))
}
}
if (oneSided == "right") {
if (BF10wText >= BF01wText) {
wBF <- bquote(BF["+"][0] == .(BF10wt))
} else {
wBF <- bquote(BF[0]["+"] == .(BF01wt))
}
}
if (oneSided == "left") {
if (BF10wText >= BF01wText) {
wBF <- bquote(BF["-"][0] == .(BF10wt))
} else {
wBF <- bquote(BF[0]["-"] == .(BF01wt))
}
}
# BFultrawide
BF01ultraText <- 1/BF10ultraText
if (BF10ultraText >= 1000000 | BF01ultraText >= 1000000) {
BF10ultrat <- format(BF10ultraText, digits = 4, scientific = TRUE)
BF01ultrat <- format(BF01ultraText, digits = 4, scientific = TRUE)
}
if (BF10ultraText < 1000000 & BF01ultraText < 1000000) {
BF10ultrat <- formatC(BF10ultraText, 3, format = "f")
BF01ultrat <- formatC(BF01ultraText, 3, format = "f")
}
if (oneSided == FALSE) {
if (BF10ultraText >= BF01ultraText) {
ultraBF <- bquote(BF[10] == .(BF10ultrat))
} else {
ultraBF <- bquote(BF[0][1] == .(BF01ultrat))
}
}
if (oneSided == "right") {
if (BF10ultraText >= BF01ultraText) {
ultraBF <- bquote(BF["+"][0] == .(BF10ultrat))
} else {
ultraBF <- bquote(BF[0]["+"] == .(BF01ultrat))
}
}
if (oneSided == "left") {
if (BF10ultraText >= BF01ultraText) {
ultraBF <- bquote(BF["-"][0] == .(BF10ultrat))
} else {
ultraBF <- bquote(BF[0]["-"] == .(BF01ultrat))
}
}
xx <- grconvertX(0.2, "ndc", "user")
yy <- grconvertY(0.965, "ndc", "user")
BFind <- sort(c(BF10userText, BF10ultraText, BF10wText), decreasing = TRUE,
index.return = TRUE)$ix
BFsort <- sort(c(BF10userText, BF10ultraText, BF10wText), decreasing = TRUE,
index.return = TRUE)$x
legend <- c("user prior:", "ultrawide prior:", "wide prior:")
pt.bg <- c("grey", "white", "black")
pt.cex <- c(cexPoints, 1.1, 1.1)
legend(xx, yy, legend = legend[BFind], pch = rep(21, 3), pt.bg = pt.bg[BFind],
bty = "n", cex = cexLegend, lty = rep(NULL, 3), pt.lwd = rep(1.3,
3), pt.cex = pt.cex[BFind])
xx <- grconvertX(0.5, "ndc", "user")
y1 <- grconvertY(0.902, "ndc", "user")
y2 <- grconvertY(0.852, "ndc", "user")
y3 <- grconvertY(0.802, "ndc", "user")
yy <- c(y1, y2, y3)
text(xx, yy[BFsort == BF10userText], userBF, cex = 1.3, pos = 4)
text(xx, yy[BFsort == BF10ultraText], ultraBF, cex = 1.3, pos = 4)
text(xx, yy[BFsort == BF10wText], wBF, cex = 1.3, pos = 4)
}
### generate data ###
set.seed(1)
x <- rnorm(30, 0.15)
### calculate Bayes factor ###
library(BayesFactor)
BF <- extractBF(ttestBF(x, rscale = "medium"), onlybf = TRUE)
### plot ###
.plotBF.robustnessCheck.ttest(x = x, BF10post = BF, rscale = "medium")
11.4 Evidential Flow
This graph shows the evidential flow, the fluctuations in the Bayes factor (y-axis) as the data accumulate (x-axis).
Show R-Codelibrary(BayesFactor)
library(plotrix)
.plotSequentialBF.ttest <- function(x = NULL, y = NULL, paired = FALSE,
BF10post, formula = NULL, data = NULL, rscale = 1, oneSided = FALSE,
lwd = 2, cexPoints = 1.4, cexAxis = 1.2, cexYlab = 1.5, cexXlab = 1.6,
cexTextBF = 1.4, cexText = 1.2, cexLegend = 1.2, cexEvidence = 1.6,
lwdAxis = 1.2, plotDifferentPriors = FALSE, BFH1H0 = TRUE, dontPlotData = FALSE,
level1 = NULL, level2 = NULL, subDataSet = NULL) {
#### settings ####
if (!plotDifferentPriors) {
evidenceText <- TRUE
} else {
evidenceText <- FALSE
}
if (rscale == "medium") {
r <- sqrt(2)/2
}
if (rscale == "wide") {
r <- 1
}
if (rscale == "ultrawide") {
r <- sqrt(2)
}
if (mode(rscale) == "numeric") {
r <- rscale
}
if (oneSided == FALSE) {
nullInterval <- NULL
}
if (oneSided == "right") {
nullInterval <- c(0, Inf)
}
if (oneSided == "left") {
nullInterval <- c(-Inf, 0)
}
par(mar = c(5.6, 6, 7, 7) + 0.1, las = 1)
if (dontPlotData) {
plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE,
xlab = "", ylab = "")
axis(1, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis,
xlab = "")
axis(2, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis,
ylab = "")
mtext("n", side = 1, cex = cexXlab, line = 2.5)
if (oneSided == FALSE) {
if (BFH1H0) {
mtext(text = expression(BF[1][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0][1]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
if (oneSided == "right") {
if (BFH1H0) {
mtext(text = expression(BF["+"][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["+"]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
if (oneSided == "left") {
if (BFH1H0) {
mtext(text = expression(BF["-"][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["-"]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
return()
}
if (is.null(y) || paired) {
BF10 <- vector("numeric", max(length(x), length(y)))
BF10w <- vector("numeric", max(length(x), length(y)))
BF10u <- vector("numeric", max(length(x), length(y)))
idData <- 1
if (is.null(y)) {
ind <- which(x == x[1])
idData <- sum((ind + 1) - (1:(length(ind))) == 1)
} else {
idData <- 1
for (i in 2:(min(c(length(x), length(y))))) {
previous <- c(x[i - 1], y[i - 1])
if (all(c(x[i], y[i]) == previous)) {
idData <- idData + 1
} else if (x[i] == y[i]) {
idData <- idData + 1
} else {
break
}
}
}
BF10[1:idData] <- 1
BF10w[1:idData] <- 1
BF10u[1:idData] <- 1
if (idData < length(x)) {
i <- idData + 1
} else {
i <- idData
}
if (idData < length(y)) {
j <- idData + 1
} else {
j <- idData
}
k <- idData + 1
while ((i <= length(x) | j <= length(y)) & k <= length(BF10)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired,
rscale = r, nullInterval = nullInterval)
BF10[k] <- BayesFactor::extractBF(BF, logbf = FALSE, onlybf = F)[1,
"bf"]
} else {
BF10[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j],
paired = paired, r = r, oneSided = oneSided)
}
k <- k + 1
if (i < length(x)) {
i <- i + 1
}
if (j < length(y)) {
j <- j + 1
}
}
BF10 <- BF10[is.finite(BF10)]
if (plotDifferentPriors) {
if (idData < length(x)) {
i <- idData + 1
} else {
i <- idData
}
if (idData < length(y)) {
j <- idData + 1
} else {
j <- idData
}
k <- idData + 1
while ((i <= length(x) | j <= length(y)) & k <= length(BF10u)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired,
rscale = "ultrawide", nullInterval = nullInterval)
BF10u[k] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else {
BF10u[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j],
paired = paired, r = "ultrawide", oneSided = oneSided)
}
k <- k + 1
if (i < length(x)) {
i <- i + 1
}
if (j < length(y)) {
j <- j + 1
}
}
BF10u <- BF10u[is.finite(BF10u)]
if (idData < length(x)) {
i <- idData + 1
} else {
i <- idData
}
if (idData < length(y)) {
j <- idData + 1
} else {
j <- idData
}
k <- idData + 1
while ((i <= length(x) | j <= length(y)) & k <= length(BF10w)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired,
rscale = "wide", nullInterval = nullInterval)
BF10w[k] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else {
BF10w[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j],
paired = paired, r = "wide", oneSided = oneSided)
}
k <- k + 1
if (i < length(x)) {
i <- i + 1
}
if (j < length(y)) {
j <- j + 1
}
}
BF10w <- BF10w[is.finite(BF10w)]
}
} else if (!is.null(y) && !paired) {
idData <- 1
xx <- numeric()
yy <- numeric()
BF10 <- vector("numeric", nrow(subDataSet))
BF10w <- vector("numeric", nrow(subDataSet))
BF10u <- vector("numeric", nrow(subDataSet))
for (i in seq_len(nrow(subDataSet))) {
if (subDataSet[i, 2] == level1) {
xx <- c(xx, subDataSet[i, 1])
} else if (subDataSet[i, 2] == level2) {
yy <- c(yy, subDataSet[i, 1])
}
if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 || sd(yy) >
0)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired,
rscale = r, nullInterval = nullInterval)
BF10[i] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else if (oneSided == "right") {
BF10[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right",
r = r)
} else if (oneSided == "left") {
BF10[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left",
r = r)
}
} else {
BF10[i] <- 1
}
}
if (plotDifferentPriors) {
xx <- numeric()
yy <- numeric()
for (i in seq_len(nrow(subDataSet))) {
if (subDataSet[i, 2] == level1) {
xx <- c(xx, subDataSet[i, 1])
} else if (subDataSet[i, 2] == level2) {
yy <- c(yy, subDataSet[i, 1])
}
if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 ||
sd(yy) > 0)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired,
rscale = "ultrawide", nullInterval = nullInterval)
BF10u[i] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else if (oneSided == "right") {
BF10u[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right",
r = "ultrawide")
} else if (oneSided == "left") {
BF10u[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left",
r = "ultrawide")
}
} else {
BF10u[i] <- 1
}
}
xx <- numeric()
yy <- numeric()
for (i in seq_len(nrow(subDataSet))) {
if (subDataSet[i, 2] == level1) {
xx <- c(xx, subDataSet[i, 1])
} else if (subDataSet[i, 2] == level2) {
yy <- c(yy, subDataSet[i, 1])
}
if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 ||
sd(yy) > 0)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired,
rscale = "wide", nullInterval = nullInterval)
BF10w[i] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else if (oneSided == "right") {
BF10w[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right",
r = "wide")
} else if (oneSided == "left") {
BF10w[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left",
r = "wide")
}
} else {
BF10w[i] <- 1
}
}
}
}
####################### scale y axis ###########################
if (plotDifferentPriors) {
BF <- c(BF10, BF10u, BF10w)
} else {
BF <- BF10
}
if (!BFH1H0) {
BF <- 1/BF
BF10 <- 1/BF10
if (plotDifferentPriors) {
BF10u <- 1/BF10u
BF10w <- 1/BF10w
}
}
# y-axis labels larger than 1
y1h <- "1"
i <- 1
while (eval(parse(text = y1h[i])) < max(BF)) {
if (grepl(pattern = "e", y1h[i])) {
newy <- paste(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y1h[i], "0", sep = "")
}
if (eval(parse(text = newy)) >= 10^6) {
newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
}
y1h <- c(y1h, newy)
i <- i + 1
}
y3h <- "3"
i <- 1
while (eval(parse(text = y3h[i])) < max(BF)) {
if (grepl(pattern = "e", y3h[i])) {
newy <- paste(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y3h[i], "0", sep = "")
}
if (as.numeric(newy) >= 10^6) {
newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
}
y3h <- c(y3h, newy)
i <- i + 1
}
yhigh <- vector("numeric", length(y1h) + length(y3h))
o <- 1
e <- 1
for (i in seq_along(yhigh)) {
if (i%%2 == 1) {
yhigh[i] <- y1h[o]
o <- o + 1
}
if (i%%2 == 0) {
yhigh[i] <- y3h[e]
e <- e + 1
}
}
yhighLab <- as.character(yhigh)
# y-axis labels smaller than 1
y1l <- "1/1"
i <- 1
while (eval(parse(text = y1l[i])) > min(BF)) {
if (grepl(pattern = "e", y1l[i])) {
newy <- paste(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y1l[i], "0", sep = "")
}
if (eval(parse(text = newy)) <= 10^(-6)) {
newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
newy <- sub("-", "+", x = newy)
newy <- paste0("1/", newy)
}
y1l <- c(y1l, newy)
i <- i + 1
}
y3l <- "1/3"
i <- 1
while (eval(parse(text = y3l[i])) > min(BF)) {
if (grepl(pattern = "e", y3l[i])) {
newy <- paste(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y3l[i], "0", sep = "")
}
if (newy == "1/3e+9") {
newy <- "1/3e+09"
}
if (eval(parse(text = newy)) <= 10^(-6) & eval(parse(text = newy)) >
10^(-9)) {
newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
newy <- paste(substring(newy, 1, nchar(newy) - 1), as.numeric(substring(newy,
nchar(newy), nchar(newy))) - 1, sep = "")
newy <- sub(".33", "", newy)
newy <- sub("-", "+", x = newy)
newy <- paste0("1/", newy)
}
y3l <- c(y3l, newy)
i <- i + 1
}
ylow <- vector("numeric", length(y1l) + length(y3l))
o <- 1
e <- 1
for (i in seq_along(ylow)) {
if (i%%2 == 1) {
ylow[i] <- y1l[o]
o <- o + 1
}
if (i%%2 == 0) {
ylow[i] <- y3l[e]
e <- e + 1
}
}
yLab <- c(rev(ylow[-1]), yhighLab)
# remove 3's if yLab vector is too long
omit3s <- FALSE
if (length(yLab) > 9) {
omit3s <- TRUE
ind <- which(yLab == "3")
yLabsHigh <- yLab[ind:length(yLab)]
if (length(yLabsHigh) > 1) {
yLabsHigh <- yLabsHigh[seq(2, length(yLabsHigh), 2)]
} else {
yLabsHigh <- character(0)
}
yLabsLow <- yLab[1:(ind - 1)]
yLabsLow <- yLabsLow[-grep(pattern = "/3", x = yLab)]
yLab1s <- c(yLabsLow, yLabsHigh)
if (max(BF) > eval(parse(text = yLab1s[length(yLab1s)]))) {
for (i in 1:2) {
if (grepl(pattern = "e", yLab1s[length(yLab1s)])) {
newy <- paste(strsplit(yLab1s[length(yLab1s)], split = "+",
fixed = TRUE)[[1]][1], "+", as.numeric(strsplit(yLab1s[length(yLab1s)],
split = "+", fixed = TRUE)[[1]][2]) + 1, sep = "")
} else {
newy <- paste(yLab1s[length(yLab1s)], "0", sep = "")
}
if (eval(parse(text = newy)) >= 10^6) {
newy <- format(eval(parse(text = newy)), digits = 3,
scientific = TRUE)
}
yLab1s <- c(yLab1s, newy)
}
}
if (yLab1s[1] == "1") {
yLab1s <- c(paste0(yLab1s[1], "/", "10"), yLab1s)
}
if (yLab1s[length(yLab1s)] == "1") {
yLab1s <- c(yLab1s, "10")
}
if (min(BF) < eval(parse(text = yLab1s[1]))) {
for (i in 1:2) {
if (grepl(pattern = "e", yLab1s[1])) {
newy <- paste(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(yLab1s[1], "0", sep = "")
}
if (eval(parse(text = newy)) <= 10^(-6)) {
newy <- format(eval(parse(text = newy)), digits = 3,
scientific = TRUE)
newy <- sub("-", "+", x = newy)
newy <- substring(newy, nchar(newy) - 4, nchar(newy))
newy <- paste0("1/", newy)
}
}
yLab1s <- c(newy, yLab1s)
}
yLab <- yLab1s
}
while (length(yLab) > 9) {
ind <- which(yLab == "1")
if (ind == 1) {
yLabLow <- character(0)
} else {
yLabLow <- yLab[1:(ind - 1)]
}
if (ind == length(yLab)) {
yLabHigh <- character(0)
} else {
yLabHigh <- yLab[(ind + 1):length(yLab)]
}
if (length(yLabLow) > 1) {
yLabLow <- yLabLow[seq(length(yLabLow) - 1, 1, -2)]
} else {
yLabLow <- yLabLow
}
if (length(yLabHigh) > 1) {
yLabHigh <- yLabHigh[seq(2, length(yLabHigh), 2)]
} else {
yLabHigh <- yLabHigh
}
if (length(yLabLow) == 1) {
yLabLow <- paste("1/", yLabHigh[1], sep = "")
}
if (length(yLabHigh) == 1) {
yLabHigh <- strsplit(x = yLabLow[1], "/", fixed = TRUE)[[1]][2]
}
yLab <- c(rev(yLabLow), "1", yLabHigh)
}
while (eval(parse(text = yLab[1])) > min(BF)) {
for (i in 1:2) {
interval <- as.numeric(strsplit(yLab[1], "+", fixed = TRUE)[[1]][2]) -
as.numeric(strsplit(yLab[2], "+", fixed = TRUE)[[1]][2])
pot <- as.numeric(strsplit(yLab[1], "+", fixed = TRUE)[[1]][2]) +
interval
newy <- paste(strsplit(yLab[1], "+", fixed = TRUE)[[1]][1],
"+", pot, sep = "")
yLab <- c(newy, yLab)
}
}
while (eval(parse(text = yLab[length(yLab)])) < max(BF)) {
for (i in 1:2) {
interval <- as.numeric(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][2]) -
as.numeric(strsplit(yLab[length(yLab) - 1], "+", fixed = TRUE)[[1]][2])
pot <- as.numeric(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][2]) +
interval
newy <- paste(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][1],
"+", pot, sep = "")
yLab <- c(yLab, newy)
}
}
yAt <- vector("numeric", length(yLab))
for (i in seq_along(yLab)) {
yAt[i] <- log(eval(parse(text = yLab[i])))
}
####################### plot ###########################
xLab <- pretty(c(0, length(BF10) + 2))
xlim <- range(xLab)
ylow <- log(eval(parse(text = yLab[1])))
yhigh <- log(eval(parse(text = yLab[length(yLab)])))
if (is.infinite(yhigh)) {
yhigh <- 1e+308
}
ylim <- c(ylow, yhigh)
plot(1, 1, xlim = xlim, ylim = ylim, ylab = "", xlab = "", type = "n",
axes = FALSE)
for (i in seq_along(yAt)) {
lines(x = xlim, y = rep(yAt[i], 2), col = "darkgrey", lwd = 1.3,
lty = 2)
}
lines(xlim, rep(0, 2), lwd = lwd)
axis(1, at = xLab, labels = xLab, cex.axis = cexAxis, lwd = lwdAxis)
axis(2, at = yAt, labels = yLab, cex.axis = cexAxis, lwd = lwdAxis)
# enable plotting in margin
par(xpd = TRUE)
xx <- grconvertX(0.79, "ndc", "user")
yAthigh <- yAt[yAt >= 0]
if (!omit3s & eval(parse(text = yLab[1])) >= 1/300 & eval(parse(text = yLab[length(yLab)])) <=
300) {
for (i in 1:(length(yAthigh) - 1)) {
yy <- mean(c(yAthigh[i], yAthigh[i + 1]))
if (yAthigh[i] == log(1)) {
text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(3)) {
text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(10)) {
text(x = xx, yy, "Strong", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(30)) {
text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(100)) {
text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
}
}
yAtlow <- rev(yAt[yAt <= 0])
for (i in 1:(length(yAtlow) - 1)) {
yy <- mean(c(yAtlow[i], yAtlow[i + 1]))
if (yAtlow[i] == log(1)) {
text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/3)) {
text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/10)) {
text(x = xx, yy, "Strong", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/30)) {
text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/100)) {
text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
}
}
axis(side = 4, at = yAt, tick = TRUE, las = 2, cex.axis = cexAxis,
lwd = lwdAxis, labels = FALSE, line = -0.6)
xx <- grconvertX(0.96, "ndc", "user")
yy <- grconvertY(0.5, "npc", "user")
text(xx, yy, "Evidence", srt = -90, cex = cexEvidence)
}
if (omit3s) {
if (oneSided == FALSE) {
if (BFH1H0) {
mtext(text = expression(BF[1][0]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
} else {
mtext(text = expression(BF[0][1]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
}
}
if (oneSided == "right") {
if (BFH1H0) {
mtext(text = expression(BF["+"][0]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
} else {
mtext(text = expression(BF[0]["+"]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
}
}
if (oneSided == "left") {
if (BFH1H0) {
mtext(text = expression(BF["-"][0]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
} else {
mtext(text = expression(BF[0]["-"]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
}
}
}
if (omit3s == FALSE) {
if (oneSided == FALSE) {
if (BFH1H0) {
mtext(text = expression(BF[1][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0][1]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
if (oneSided == "right") {
if (BFH1H0) {
mtext(text = expression(BF["+"][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["+"]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
if (oneSided == "left") {
if (BFH1H0) {
mtext(text = expression(BF["-"][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["-"]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
}
mtext("n", side = 1, cex = cexXlab, line = 2.5)
xx <- grconvertX(0.1, "npc", "user")
yy1 <- yAt[length(yAt) - 1]
yy2 <- yAt[length(yAt)]
yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
xxt <- grconvertX(0.28, "npc", "user")
if (oneSided == FALSE) {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
}
}
if (oneSided == "right") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
}
}
if (oneSided == "left") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
}
}
yy1 <- yAt[2]
yy2 <- yAt[1]
yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
if (oneSided == FALSE) {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1",
cex = cexText)
}
}
if (oneSided == "right") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+",
cex = cexText)
}
}
if (oneSided == "left") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-",
cex = cexText)
}
}
# display BF10 value
if (idData < length(BF10)) {
BF10e <- BF10post
} else {
BF10e <- 1
}
if (BFH1H0) {
BF01e <- 1/BF10e
} else {
BF01e <- BF10e
BF10e <- 1/BF01e
}
# display BF10 value
offsetTopPart <- 0.06
xx <- min(xLab)
yy <- grconvertY(0.75 + offsetTopPart, "ndc", "user")
yy2 <- grconvertY(0.806 + offsetTopPart, "ndc", "user")
if (BF10e >= 1000000 | BF01e >= 1000000) {
BF10t <- formatC(BF10e, 3, format = "e")
BF01t <- formatC(BF01e, 3, format = "e")
}
if (BF10e < 1000000 & BF01e < 1000000) {
BF10t <- formatC(BF10e, 3, format = "f")
BF01t <- formatC(BF01e, 3, format = "f")
}
if (oneSided == FALSE) {
text(xx, yy2, bquote(BF[10] == .(BF10t)), cex = cexTextBF, pos = 4,
offset = -0.2)
text(xx, yy, bquote(BF[0][1] == .(BF01t)), cex = cexTextBF, pos = 4,
offset = -0.2)
}
if (oneSided == "right") {
text(xx, yy2, bquote(BF["+"][0] == .(BF10t)), cex = cexTextBF,
pos = 4, offset = -0.2)
text(xx, yy, bquote(BF[0]["+"] == .(BF01t)), cex = cexTextBF,
pos = 4, offset = -0.2)
}
if (oneSided == "left") {
text(xx, yy2, bquote(BF["-"][0] == .(BF10t)), cex = cexTextBF,
pos = 4, offset = -0.2)
text(xx, yy, bquote(BF[0]["-"] == .(BF01t)), cex = cexTextBF,
pos = 4, offset = -0.2)
}
# probability wheel
if (max(nchar(BF10t), nchar(BF01t)) <= 4) {
xx <- grconvertX(0.44, "ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 5) {
xx <- grconvertX(0.44 + 0.001 * 5, "ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 6) {
xx <- grconvertX(0.44 + 0.001 * 6, "ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 7) {
xx <- grconvertX(0.44 + 0.002 * max(nchar(BF10t), nchar(BF01t)),
"ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 8) {
xx <- grconvertX(0.44 + 0.003 * max(nchar(BF10t), nchar(BF01t)),
"ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) > 8) {
xx <- grconvertX(0.445 + 0.005 * max(nchar(BF10t), nchar(BF01t)),
"ndc", "user")
}
yy <- grconvertY(0.788 + offsetTopPart, "ndc", "user")
# make sure that colored area is centered
radius <- grconvertX(0.2, "ndc", "user") - grconvertX(0.16, "ndc",
"user")
A <- radius^2 * pi
alpha <- 2/(BF01e + 1) * A/radius^2
startpos <- pi/2 - alpha/2
# draw probability wheel
plotrix::floating.pie(xx, yy, c(BF10e, 1), radius = radius, col = c("darkred",
"white"), lwd = 2, startpos = startpos)
yy <- grconvertY(0.865 + offsetTopPart, "ndc", "user")
yy2 <- grconvertY(0.708 + offsetTopPart, "ndc", "user")
if (oneSided == FALSE) {
text(xx, yy, "data|H1", cex = 1.1)
text(xx, yy2, "data|H0", cex = 1.1)
}
if (oneSided == "right") {
text(xx, yy, "data|H+", cex = 1.1)
text(xx, yy2, "data|H0", cex = 1.1)
}
if (oneSided == "left") {
text(xx, yy, "data|H-", cex = 1.1)
text(xx, yy2, "data|H0", cex = 1.1)
}
if (length(BF10) <= 60) {
points(log(BF10), pch = 21, bg = "grey", cex = cexPoints, lwd = 1.3) # user prior
} else {
lines(log(BF10), col = "black", lwd = 2.7) # user prior
}
if (plotDifferentPriors) {
if (length(BF10) <= 60) {
points(log(BF10u), pch = 21, bg = "white", cex = 0.7, lwd = 1.3) # 'ultrawide' prior
points(log(BF10w), pch = 21, bg = "black", cex = 0.7, lwd = 1.3) # 'wide' prior
} else {
greycol <- rgb(0, 0, 0, alpha = 0.95)
greycol2 <- rgb(0, 0, 0, alpha = 0.5)
lines(log(BF10u), col = greycol2, cex = 0.7, lwd = 1.3, lty = 1) # 'ultrawide' prior
lines(log(BF10w), col = greycol, cex = 0.7, lwd = 1.3, lty = 3) # 'wide' prior
}
}
BFevidence <- BF10e
if (evidenceText) {
if (BF10e < 1) {
BFevidence <- 1/BF10e
}
if (BFevidence >= 1 & BFevidence <= 3) {
lab <- "Anecdotal"
}
if (BFevidence > 3 & BFevidence <= 10) {
lab <- "Moderate"
}
if (BFevidence > 10 & BFevidence <= 30) {
lab <- "Strong"
}
if (BFevidence > 30 & BFevidence <= 100) {
lab <- "Very strong"
}
if (BFevidence > 100) {
lab <- "Extreme"
}
xxT <- max(xLab)
yyT <- grconvertY(0.775 + offsetTopPart, "ndc", "user")
if (BF10e >= 1) {
if (oneSided == FALSE) {
text(xxT, yyT, paste("Evidence for H1:\n", lab), cex = 1.4,
pos = 2, offset = -0.2)
}
if (oneSided == "right") {
text(xxT, yyT, paste("Evidence for H+:\n", lab), cex = 1.4,
pos = 2, offset = -0.2)
}
if (oneSided == "left") {
text(xxT, yyT, paste("Evidence for H-:\n", lab), cex = 1.4,
pos = 2, offset = -0.2)
}
}
if (BF10e < 1) {
text(xxT, yyT, paste("Evidence for H0:\n", lab), cex = 1.4,
pos = 2, offset = -0.2)
}
} else {
# add legend
xx <- grconvertX(0.56, "ndc", "user")
yy <- grconvertY(0.872 + offsetTopPart, "ndc", "user")
BFind <- sort(c(BF10[length(x)], BF10u[length(x)], BF10w[length(x)]),
decreasing = TRUE, index.return = TRUE)$ix
legend <- c("user prior", "ultrawide prior", "wide prior")
if (length(BF10) <= 60) {
pt.bg <- c("grey", "white", "black")
pt.cex <- c(cexPoints, 0.7, 0.7)
legend(xx, yy, legend = legend[BFind], pch = rep(21, 3), pt.bg = pt.bg[BFind],
bty = "n", cex = cexLegend, lty = rep(NULL, 3), pt.lwd = rep(1.3,
3), pt.cex = pt.cex[BFind])
} else {
xx <- grconvertX(0.55, "ndc", "user")
lty <- c(1, 1, 3)
lwd <- c(2.7, 1.3, 1.3)
col <- c("black", greycol2, greycol)
legend(xx, yy, legend = legend[BFind], lty = lty[BFind], bty = "n",
cex = cexLegend, lwd = lwd[BFind], col = col[BFind], seg.len = 0.7)
}
}
}
### generate data ###
set.seed(1)
x <- rnorm(30, 0.15)
### calculate Bayes factor ###
library(BayesFactor)
BF <- extractBF(ttestBF(x, rscale = "medium"), onlybf = TRUE)
### plot ###
.plotSequentialBF.ttest(x = x, BF10post = BF, rscale = "medium")
11.5 Evidential Flow with Robustness Check
The graph adds a robustness check by displying the evidential flow for different prior choices.
Show R-Codelibrary(BayesFactor)
library(plotrix)
.plotSequentialBF.ttest <- function(x = NULL, y = NULL, paired = FALSE,
BF10post, formula = NULL, data = NULL, rscale = 1, oneSided = FALSE,
lwd = 2, cexPoints = 1.4, cexAxis = 1.2, cexYlab = 1.5, cexXlab = 1.6,
cexTextBF = 1.4, cexText = 1.2, cexLegend = 1.2, cexEvidence = 1.6,
lwdAxis = 1.2, plotDifferentPriors = FALSE, BFH1H0 = TRUE, dontPlotData = FALSE,
level1 = NULL, level2 = NULL, subDataSet = NULL) {
#### settings ####
if (!plotDifferentPriors) {
evidenceText <- TRUE
} else {
evidenceText <- FALSE
}
if (rscale == "medium") {
r <- sqrt(2)/2
}
if (rscale == "wide") {
r <- 1
}
if (rscale == "ultrawide") {
r <- sqrt(2)
}
if (mode(rscale) == "numeric") {
r <- rscale
}
if (oneSided == FALSE) {
nullInterval <- NULL
}
if (oneSided == "right") {
nullInterval <- c(0, Inf)
}
if (oneSided == "left") {
nullInterval <- c(-Inf, 0)
}
par(mar = c(5.6, 6, 7, 7) + 0.1, las = 1)
if (dontPlotData) {
plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE,
xlab = "", ylab = "")
axis(1, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis,
xlab = "")
axis(2, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis,
ylab = "")
mtext("n", side = 1, cex = cexXlab, line = 2.5)
if (oneSided == FALSE) {
if (BFH1H0) {
mtext(text = expression(BF[1][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0][1]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
if (oneSided == "right") {
if (BFH1H0) {
mtext(text = expression(BF["+"][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["+"]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
if (oneSided == "left") {
if (BFH1H0) {
mtext(text = expression(BF["-"][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["-"]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
return()
}
if (is.null(y) || paired) {
BF10 <- vector("numeric", max(length(x), length(y)))
BF10w <- vector("numeric", max(length(x), length(y)))
BF10u <- vector("numeric", max(length(x), length(y)))
idData <- 1
if (is.null(y)) {
ind <- which(x == x[1])
idData <- sum((ind + 1) - (1:(length(ind))) == 1)
} else {
idData <- 1
for (i in 2:(min(c(length(x), length(y))))) {
previous <- c(x[i - 1], y[i - 1])
if (all(c(x[i], y[i]) == previous)) {
idData <- idData + 1
} else if (x[i] == y[i]) {
idData <- idData + 1
} else {
break
}
}
}
BF10[1:idData] <- 1
BF10w[1:idData] <- 1
BF10u[1:idData] <- 1
if (idData < length(x)) {
i <- idData + 1
} else {
i <- idData
}
if (idData < length(y)) {
j <- idData + 1
} else {
j <- idData
}
k <- idData + 1
while ((i <= length(x) | j <= length(y)) & k <= length(BF10)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired,
rscale = r, nullInterval = nullInterval)
BF10[k] <- BayesFactor::extractBF(BF, logbf = FALSE, onlybf = F)[1,
"bf"]
} else {
BF10[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j],
paired = paired, r = r, oneSided = oneSided)
}
k <- k + 1
if (i < length(x)) {
i <- i + 1
}
if (j < length(y)) {
j <- j + 1
}
}
BF10 <- BF10[is.finite(BF10)]
if (plotDifferentPriors) {
if (idData < length(x)) {
i <- idData + 1
} else {
i <- idData
}
if (idData < length(y)) {
j <- idData + 1
} else {
j <- idData
}
k <- idData + 1
while ((i <= length(x) | j <= length(y)) & k <= length(BF10u)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired,
rscale = "ultrawide", nullInterval = nullInterval)
BF10u[k] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else {
BF10u[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j],
paired = paired, r = "ultrawide", oneSided = oneSided)
}
k <- k + 1
if (i < length(x)) {
i <- i + 1
}
if (j < length(y)) {
j <- j + 1
}
}
BF10u <- BF10u[is.finite(BF10u)]
if (idData < length(x)) {
i <- idData + 1
} else {
i <- idData
}
if (idData < length(y)) {
j <- idData + 1
} else {
j <- idData
}
k <- idData + 1
while ((i <= length(x) | j <= length(y)) & k <= length(BF10w)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired,
rscale = "wide", nullInterval = nullInterval)
BF10w[k] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else {
BF10w[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j],
paired = paired, r = "wide", oneSided = oneSided)
}
k <- k + 1
if (i < length(x)) {
i <- i + 1
}
if (j < length(y)) {
j <- j + 1
}
}
BF10w <- BF10w[is.finite(BF10w)]
}
} else if (!is.null(y) && !paired) {
idData <- 1
xx <- numeric()
yy <- numeric()
BF10 <- vector("numeric", nrow(subDataSet))
BF10w <- vector("numeric", nrow(subDataSet))
BF10u <- vector("numeric", nrow(subDataSet))
for (i in seq_len(nrow(subDataSet))) {
if (subDataSet[i, 2] == level1) {
xx <- c(xx, subDataSet[i, 1])
} else if (subDataSet[i, 2] == level2) {
yy <- c(yy, subDataSet[i, 1])
}
if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 || sd(yy) >
0)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired,
rscale = r, nullInterval = nullInterval)
BF10[i] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else if (oneSided == "right") {
BF10[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right",
r = r)
} else if (oneSided == "left") {
BF10[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left",
r = r)
}
} else {
BF10[i] <- 1
}
}
if (plotDifferentPriors) {
xx <- numeric()
yy <- numeric()
for (i in seq_len(nrow(subDataSet))) {
if (subDataSet[i, 2] == level1) {
xx <- c(xx, subDataSet[i, 1])
} else if (subDataSet[i, 2] == level2) {
yy <- c(yy, subDataSet[i, 1])
}
if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 ||
sd(yy) > 0)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired,
rscale = "ultrawide", nullInterval = nullInterval)
BF10u[i] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else if (oneSided == "right") {
BF10u[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right",
r = "ultrawide")
} else if (oneSided == "left") {
BF10u[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left",
r = "ultrawide")
}
} else {
BF10u[i] <- 1
}
}
xx <- numeric()
yy <- numeric()
for (i in seq_len(nrow(subDataSet))) {
if (subDataSet[i, 2] == level1) {
xx <- c(xx, subDataSet[i, 1])
} else if (subDataSet[i, 2] == level2) {
yy <- c(yy, subDataSet[i, 1])
}
if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 ||
sd(yy) > 0)) {
if (oneSided == FALSE) {
BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired,
rscale = "wide", nullInterval = nullInterval)
BF10w[i] <- BayesFactor::extractBF(BF, logbf = FALSE,
onlybf = F)[1, "bf"]
} else if (oneSided == "right") {
BF10w[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right",
r = "wide")
} else if (oneSided == "left") {
BF10w[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left",
r = "wide")
}
} else {
BF10w[i] <- 1
}
}
}
}
####################### scale y axis ###########################
if (plotDifferentPriors) {
BF <- c(BF10, BF10u, BF10w)
} else {
BF <- BF10
}
if (!BFH1H0) {
BF <- 1/BF
BF10 <- 1/BF10
if (plotDifferentPriors) {
BF10u <- 1/BF10u
BF10w <- 1/BF10w
}
}
# y-axis labels larger than 1
y1h <- "1"
i <- 1
while (eval(parse(text = y1h[i])) < max(BF)) {
if (grepl(pattern = "e", y1h[i])) {
newy <- paste(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y1h[i], "0", sep = "")
}
if (eval(parse(text = newy)) >= 10^6) {
newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
}
y1h <- c(y1h, newy)
i <- i + 1
}
y3h <- "3"
i <- 1
while (eval(parse(text = y3h[i])) < max(BF)) {
if (grepl(pattern = "e", y3h[i])) {
newy <- paste(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y3h[i], "0", sep = "")
}
if (as.numeric(newy) >= 10^6) {
newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
}
y3h <- c(y3h, newy)
i <- i + 1
}
yhigh <- vector("numeric", length(y1h) + length(y3h))
o <- 1
e <- 1
for (i in seq_along(yhigh)) {
if (i%%2 == 1) {
yhigh[i] <- y1h[o]
o <- o + 1
}
if (i%%2 == 0) {
yhigh[i] <- y3h[e]
e <- e + 1
}
}
yhighLab <- as.character(yhigh)
# y-axis labels smaller than 1
y1l <- "1/1"
i <- 1
while (eval(parse(text = y1l[i])) > min(BF)) {
if (grepl(pattern = "e", y1l[i])) {
newy <- paste(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y1l[i], "0", sep = "")
}
if (eval(parse(text = newy)) <= 10^(-6)) {
newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
newy <- sub("-", "+", x = newy)
newy <- paste0("1/", newy)
}
y1l <- c(y1l, newy)
i <- i + 1
}
y3l <- "1/3"
i <- 1
while (eval(parse(text = y3l[i])) > min(BF)) {
if (grepl(pattern = "e", y3l[i])) {
newy <- paste(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(y3l[i], "0", sep = "")
}
if (newy == "1/3e+9") {
newy <- "1/3e+09"
}
if (eval(parse(text = newy)) <= 10^(-6) & eval(parse(text = newy)) >
10^(-9)) {
newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
newy <- paste(substring(newy, 1, nchar(newy) - 1), as.numeric(substring(newy,
nchar(newy), nchar(newy))) - 1, sep = "")
newy <- sub(".33", "", newy)
newy <- sub("-", "+", x = newy)
newy <- paste0("1/", newy)
}
y3l <- c(y3l, newy)
i <- i + 1
}
ylow <- vector("numeric", length(y1l) + length(y3l))
o <- 1
e <- 1
for (i in seq_along(ylow)) {
if (i%%2 == 1) {
ylow[i] <- y1l[o]
o <- o + 1
}
if (i%%2 == 0) {
ylow[i] <- y3l[e]
e <- e + 1
}
}
yLab <- c(rev(ylow[-1]), yhighLab)
# remove 3's if yLab vector is too long
omit3s <- FALSE
if (length(yLab) > 9) {
omit3s <- TRUE
ind <- which(yLab == "3")
yLabsHigh <- yLab[ind:length(yLab)]
if (length(yLabsHigh) > 1) {
yLabsHigh <- yLabsHigh[seq(2, length(yLabsHigh), 2)]
} else {
yLabsHigh <- character(0)
}
yLabsLow <- yLab[1:(ind - 1)]
yLabsLow <- yLabsLow[-grep(pattern = "/3", x = yLab)]
yLab1s <- c(yLabsLow, yLabsHigh)
if (max(BF) > eval(parse(text = yLab1s[length(yLab1s)]))) {
for (i in 1:2) {
if (grepl(pattern = "e", yLab1s[length(yLab1s)])) {
newy <- paste(strsplit(yLab1s[length(yLab1s)], split = "+",
fixed = TRUE)[[1]][1], "+", as.numeric(strsplit(yLab1s[length(yLab1s)],
split = "+", fixed = TRUE)[[1]][2]) + 1, sep = "")
} else {
newy <- paste(yLab1s[length(yLab1s)], "0", sep = "")
}
if (eval(parse(text = newy)) >= 10^6) {
newy <- format(eval(parse(text = newy)), digits = 3,
scientific = TRUE)
}
yLab1s <- c(yLab1s, newy)
}
}
if (yLab1s[1] == "1") {
yLab1s <- c(paste0(yLab1s[1], "/", "10"), yLab1s)
}
if (yLab1s[length(yLab1s)] == "1") {
yLab1s <- c(yLab1s, "10")
}
if (min(BF) < eval(parse(text = yLab1s[1]))) {
for (i in 1:2) {
if (grepl(pattern = "e", yLab1s[1])) {
newy <- paste(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][1],
"+", as.numeric(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][2]) +
1, sep = "")
} else {
newy <- paste(yLab1s[1], "0", sep = "")
}
if (eval(parse(text = newy)) <= 10^(-6)) {
newy <- format(eval(parse(text = newy)), digits = 3,
scientific = TRUE)
newy <- sub("-", "+", x = newy)
newy <- substring(newy, nchar(newy) - 4, nchar(newy))
newy <- paste0("1/", newy)
}
}
yLab1s <- c(newy, yLab1s)
}
yLab <- yLab1s
}
while (length(yLab) > 9) {
ind <- which(yLab == "1")
if (ind == 1) {
yLabLow <- character(0)
} else {
yLabLow <- yLab[1:(ind - 1)]
}
if (ind == length(yLab)) {
yLabHigh <- character(0)
} else {
yLabHigh <- yLab[(ind + 1):length(yLab)]
}
if (length(yLabLow) > 1) {
yLabLow <- yLabLow[seq(length(yLabLow) - 1, 1, -2)]
} else {
yLabLow <- yLabLow
}
if (length(yLabHigh) > 1) {
yLabHigh <- yLabHigh[seq(2, length(yLabHigh), 2)]
} else {
yLabHigh <- yLabHigh
}
if (length(yLabLow) == 1) {
yLabLow <- paste("1/", yLabHigh[1], sep = "")
}
if (length(yLabHigh) == 1) {
yLabHigh <- strsplit(x = yLabLow[1], "/", fixed = TRUE)[[1]][2]
}
yLab <- c(rev(yLabLow), "1", yLabHigh)
}
while (eval(parse(text = yLab[1])) > min(BF)) {
for (i in 1:2) {
interval <- as.numeric(strsplit(yLab[1], "+", fixed = TRUE)[[1]][2]) -
as.numeric(strsplit(yLab[2], "+", fixed = TRUE)[[1]][2])
pot <- as.numeric(strsplit(yLab[1], "+", fixed = TRUE)[[1]][2]) +
interval
newy <- paste(strsplit(yLab[1], "+", fixed = TRUE)[[1]][1],
"+", pot, sep = "")
yLab <- c(newy, yLab)
}
}
while (eval(parse(text = yLab[length(yLab)])) < max(BF)) {
for (i in 1:2) {
interval <- as.numeric(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][2]) -
as.numeric(strsplit(yLab[length(yLab) - 1], "+", fixed = TRUE)[[1]][2])
pot <- as.numeric(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][2]) +
interval
newy <- paste(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][1],
"+", pot, sep = "")
yLab <- c(yLab, newy)
}
}
yAt <- vector("numeric", length(yLab))
for (i in seq_along(yLab)) {
yAt[i] <- log(eval(parse(text = yLab[i])))
}
####################### plot ###########################
xLab <- pretty(c(0, length(BF10) + 2))
xlim <- range(xLab)
ylow <- log(eval(parse(text = yLab[1])))
yhigh <- log(eval(parse(text = yLab[length(yLab)])))
if (is.infinite(yhigh)) {
yhigh <- 1e+308
}
ylim <- c(ylow, yhigh)
plot(1, 1, xlim = xlim, ylim = ylim, ylab = "", xlab = "", type = "n",
axes = FALSE)
for (i in seq_along(yAt)) {
lines(x = xlim, y = rep(yAt[i], 2), col = "darkgrey", lwd = 1.3,
lty = 2)
}
lines(xlim, rep(0, 2), lwd = lwd)
axis(1, at = xLab, labels = xLab, cex.axis = cexAxis, lwd = lwdAxis)
axis(2, at = yAt, labels = yLab, cex.axis = cexAxis, lwd = lwdAxis)
# enable plotting in margin
par(xpd = TRUE)
xx <- grconvertX(0.79, "ndc", "user")
yAthigh <- yAt[yAt >= 0]
if (!omit3s & eval(parse(text = yLab[1])) >= 1/300 & eval(parse(text = yLab[length(yLab)])) <=
300) {
for (i in 1:(length(yAthigh) - 1)) {
yy <- mean(c(yAthigh[i], yAthigh[i + 1]))
if (yAthigh[i] == log(1)) {
text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(3)) {
text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(10)) {
text(x = xx, yy, "Strong", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(30)) {
text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
}
if (yAthigh[i] == log(100)) {
text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
}
}
yAtlow <- rev(yAt[yAt <= 0])
for (i in 1:(length(yAtlow) - 1)) {
yy <- mean(c(yAtlow[i], yAtlow[i + 1]))
if (yAtlow[i] == log(1)) {
text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/3)) {
text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/10)) {
text(x = xx, yy, "Strong", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/30)) {
text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
}
if (yAtlow[i] == log(1/100)) {
text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
}
}
axis(side = 4, at = yAt, tick = TRUE, las = 2, cex.axis = cexAxis,
lwd = lwdAxis, labels = FALSE, line = -0.6)
xx <- grconvertX(0.96, "ndc", "user")
yy <- grconvertY(0.5, "npc", "user")
text(xx, yy, "Evidence", srt = -90, cex = cexEvidence)
}
if (omit3s) {
if (oneSided == FALSE) {
if (BFH1H0) {
mtext(text = expression(BF[1][0]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
} else {
mtext(text = expression(BF[0][1]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
}
}
if (oneSided == "right") {
if (BFH1H0) {
mtext(text = expression(BF["+"][0]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
} else {
mtext(text = expression(BF[0]["+"]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
}
}
if (oneSided == "left") {
if (BFH1H0) {
mtext(text = expression(BF["-"][0]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
} else {
mtext(text = expression(BF[0]["-"]), side = 2, las = 0,
cex = cexYlab, line = 4.3)
}
}
}
if (omit3s == FALSE) {
if (oneSided == FALSE) {
if (BFH1H0) {
mtext(text = expression(BF[1][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0][1]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
if (oneSided == "right") {
if (BFH1H0) {
mtext(text = expression(BF["+"][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["+"]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
if (oneSided == "left") {
if (BFH1H0) {
mtext(text = expression(BF["-"][0]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
} else {
mtext(text = expression(BF[0]["-"]), side = 2, las = 0,
cex = cexYlab, line = 3.1)
}
}
}
mtext("n", side = 1, cex = cexXlab, line = 2.5)
xx <- grconvertX(0.1, "npc", "user")
yy1 <- yAt[length(yAt) - 1]
yy2 <- yAt[length(yAt)]
yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
xxt <- grconvertX(0.28, "npc", "user")
if (oneSided == FALSE) {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
}
}
if (oneSided == "right") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
}
}
if (oneSided == "left") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
}
}
yy1 <- yAt[2]
yy2 <- yAt[1]
yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
if (oneSided == FALSE) {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1",
cex = cexText)
}
}
if (oneSided == "right") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+",
cex = cexText)
}
}
if (oneSided == "left") {
if (BFH1H0) {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0",
cex = cexText)
} else {
text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-",
cex = cexText)
}
}
# display BF10 value
if (idData < length(BF10)) {
BF10e <- BF10post
} else {
BF10e <- 1
}
if (BFH1H0) {
BF01e <- 1/BF10e
} else {
BF01e <- BF10e
BF10e <- 1/BF01e
}
# display BF10 value
offsetTopPart <- 0.06
xx <- min(xLab)
yy <- grconvertY(0.75 + offsetTopPart, "ndc", "user")
yy2 <- grconvertY(0.806 + offsetTopPart, "ndc", "user")
if (BF10e >= 1000000 | BF01e >= 1000000) {
BF10t <- formatC(BF10e, 3, format = "e")
BF01t <- formatC(BF01e, 3, format = "e")
}
if (BF10e < 1000000 & BF01e < 1000000) {
BF10t <- formatC(BF10e, 3, format = "f")
BF01t <- formatC(BF01e, 3, format = "f")
}
if (oneSided == FALSE) {
text(xx, yy2, bquote(BF[10] == .(BF10t)), cex = cexTextBF, pos = 4,
offset = -0.2)
text(xx, yy, bquote(BF[0][1] == .(BF01t)), cex = cexTextBF, pos = 4,
offset = -0.2)
}
if (oneSided == "right") {
text(xx, yy2, bquote(BF["+"][0] == .(BF10t)), cex = cexTextBF,
pos = 4, offset = -0.2)
text(xx, yy, bquote(BF[0]["+"] == .(BF01t)), cex = cexTextBF,
pos = 4, offset = -0.2)
}
if (oneSided == "left") {
text(xx, yy2, bquote(BF["-"][0] == .(BF10t)), cex = cexTextBF,
pos = 4, offset = -0.2)
text(xx, yy, bquote(BF[0]["-"] == .(BF01t)), cex = cexTextBF,
pos = 4, offset = -0.2)
}
# probability wheel
if (max(nchar(BF10t), nchar(BF01t)) <= 4) {
xx <- grconvertX(0.44, "ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 5) {
xx <- grconvertX(0.44 + 0.001 * 5, "ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 6) {
xx <- grconvertX(0.44 + 0.001 * 6, "ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 7) {
xx <- grconvertX(0.44 + 0.002 * max(nchar(BF10t), nchar(BF01t)),
"ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) == 8) {
xx <- grconvertX(0.44 + 0.003 * max(nchar(BF10t), nchar(BF01t)),
"ndc", "user")
}
if (max(nchar(BF10t), nchar(BF01t)) > 8) {
xx <- grconvertX(0.445 + 0.005 * max(nchar(BF10t), nchar(BF01t)),
"ndc", "user")
}
yy <- grconvertY(0.788 + offsetTopPart, "ndc", "user")
# make sure that colored area is centered
radius <- grconvertX(0.2, "ndc", "user") - grconvertX(0.16, "ndc",
"user")
A <- radius^2 * pi
alpha <- 2/(BF01e + 1) * A/radius^2
startpos <- pi/2 - alpha/2
# draw probability wheel
plotrix::floating.pie(xx, yy, c(BF10e, 1), radius = radius, col = c("darkred",
"white"), lwd = 2, startpos = startpos)
yy <- grconvertY(0.865 + offsetTopPart, "ndc", "user")
yy2 <- grconvertY(0.708 + offsetTopPart, "ndc", "user")
if (oneSided == FALSE) {
text(xx, yy, "data|H1", cex = 1.1)
text(xx, yy2, "data|H0", cex = 1.1)
}
if (oneSided == "right") {
text(xx, yy, "data|H+", cex = 1.1)
text(xx, yy2, "data|H0", cex = 1.1)
}
if (oneSided == "left") {
text(xx, yy, "data|H-", cex = 1.1)
text(xx, yy2, "data|H0", cex = 1.1)
}
if (length(BF10) <= 60) {
points(log(BF10), pch = 21, bg = "grey", cex = cexPoints, lwd = 1.3) # user prior
} else {
lines(log(BF10), col = "black", lwd = 2.7) # user prior
}
if (plotDifferentPriors) {
if (length(BF10) <= 60) {
points(log(BF10u), pch = 21, bg = "white", cex = 0.7, lwd = 1.3) # 'ultrawide' prior
points(log(BF10w), pch = 21, bg = "black", cex = 0.7, lwd = 1.3) # 'wide' prior
} else {
greycol <- rgb(0, 0, 0, alpha = 0.95)
greycol2 <- rgb(0, 0, 0, alpha = 0.5)
lines(log(BF10u), col = greycol2, cex = 0.7, lwd = 1.3, lty = 1) # 'ultrawide' prior
lines(log(BF10w), col = greycol, cex = 0.7, lwd = 1.3, lty = 3) # 'wide' prior
}
}
BFevidence <- BF10e
if (evidenceText) {
if (BF10e < 1) {
BFevidence <- 1/BF10e
}
if (BFevidence >= 1 & BFevidence <= 3) {
lab <- "Anecdotal"
}
if (BFevidence > 3 & BFevidence <= 10) {
lab <- "Moderate"
}
if (BFevidence > 10 & BFevidence <= 30) {
lab <- "Strong"
}
if (BFevidence > 30 & BFevidence <= 100) {
lab <- "Very strong"
}
if (BFevidence > 100) {
lab <- "Extreme"
}
xxT <- max(xLab)
yyT <- grconvertY(0.775 + offsetTopPart, "ndc", "user")
if (BF10e >= 1) {
if (oneSided == FALSE) {
text(xxT, yyT, paste("Evidence for H1:\n", lab), cex = 1.4,
pos = 2, offset = -0.2)
}
if (oneSided == "right") {
text(xxT, yyT, paste("Evidence for H+:\n", lab), cex = 1.4,
pos = 2, offset = -0.2)
}
if (oneSided == "left") {
text(xxT, yyT, paste("Evidence for H-:\n", lab), cex = 1.4,
pos = 2, offset = -0.2)
}
}
if (BF10e < 1) {
text(xxT, yyT, paste("Evidence for H0:\n", lab), cex = 1.4,
pos = 2, offset = -0.2)
}
} else {
# add legend
xx <- grconvertX(0.56, "ndc", "user")
yy <- grconvertY(0.872 + offsetTopPart, "ndc", "user")
BFind <- sort(c(BF10[length(x)], BF10u[length(x)], BF10w[length(x)]),
decreasing = TRUE, index.return = TRUE)$ix
legend <- c("user prior", "ultrawide prior", "wide prior")
if (length(BF10) <= 60) {
pt.bg <- c("grey", "white", "black")
pt.cex <- c(cexPoints, 0.7, 0.7)
legend(xx, yy, legend = legend[BFind], pch = rep(21, 3), pt.bg = pt.bg[BFind],
bty = "n", cex = cexLegend, lty = rep(NULL, 3), pt.lwd = rep(1.3,
3), pt.cex = pt.cex[BFind])
} else {
xx <- grconvertX(0.55, "ndc", "user")
lty <- c(1, 1, 3)
lwd <- c(2.7, 1.3, 1.3)
col <- c("black", greycol2, greycol)
legend(xx, yy, legend = legend[BFind], lty = lty[BFind], bty = "n",
cex = cexLegend, lwd = lwd[BFind], col = col[BFind], seg.len = 0.7)
}
}
}
### generate data ###
set.seed(1)
x <- rnorm(30, 0.15)
### calculate Bayes factor ###
library(BayesFactor)
BF <- extractBF(ttestBF(x, rscale = "medium"), onlybf = TRUE)
### plot ###
.plotSequentialBF.ttest(x = x, BF10post = BF, rscale = "medium", plotDifferentPriors = TRUE)
12 Miscellaneous
Several cool plots do not fall neatly into the above categories.
12.1 Funnel Plot
This is a funnel plot, and it is courtesy of Mark Nieuwenstein. The code depends on the meta and metafor R packages.
library(meta)
library(metafor)
UT_CT <- structure(list(HedgesG = c(0.423967347, 0.463106494, 0.24028285, 0.859968212,
0.700832432, -0.47267567, 1.478756303, -0.0956, 0.3216, 0.246, -0.276444701, -0.0888,
-0.0883, 0.507049057, 0.2715, 0.4705, 0.3825, 0.172067039, -0.503812571, -0.373979221,
0.268963583, 0.338268088, 0.179899652, -0.559086162, -0.0901, 0.0688, -0.211118367,
1.212322358, 0.575640797, -0.345344262, 0.929063226, 0.997507389, -0.205137778, -0.25576051,
-0.498009871, -0.330754639, 0.624634361, 0.667445161, 0.626010596, 0.03, 0.089677431,
0.30608501, -0.365244026, -0.051468156, 0.27, 0.355, 0.775529648, 1.041749533, -0.096,
-0.143722066, 0.0953, -0.5481, 0.865, -0.738, -0.3701, -0.6209, 0.2206, 0, 0.43,
-0.008883176), SE = c(0.328686052, 0.26286584, 0.204602057, 0.333714062, 0.380311448,
0.250787154, 0.40690344, 0.155084096, 0.223830293, 0.156204994, 0.319656905, 0.318168825,
0.318166748, 0.315652397, 0.214242853, 0.221133444, 0.237907545, 0.293797292, 0.301387511,
0.261597221, 0.249257982, 0.328900502, 0.233733134, 0.206587525, 0.35614549, 0.200541797,
0.171667711, 0.269412515, 0.288276271, 0.292372285, 0.33215153, 0.293760287, 0.336350481,
0.211909603, 0.23109561, 0.247283673, 0.306012425, 0.257261725, 0.326419813, 0.316,
0.247090732, 0.248441017, 0.280785825, 0.355341625, 0.2749, 0.27, 0.289786359, 0.402131319,
0.160312195, 0.157579079, 0.32046, 0.450998, 0.6359, 0.476, 0.1857, 0.2022, 0.302,
0.2455, 0.3162, 0.100200227), InverseSE = c(3.042416897, 3.804221963, 4.887536399,
2.996577349, 2.629423875, 3.987445069, 2.457585512, 6.448114433, 4.467670516, 6.401843997,
3.128354129, 3.142985494, 3.143006003, 3.168041834, 4.66760028, 4.522156316, 4.203313517,
3.403707343, 3.317987517, 3.822670572, 4.011907632, 3.040433186, 4.278383572, 4.840563347,
2.807841257, 4.986491677, 5.825207274, 3.711780056, 3.468894601, 3.420296833, 3.010674074,
3.404136109, 2.973089248, 4.718993315, 4.327213305, 4.04393864, 3.267841172, 3.887092026,
3.063539526, 3.164556962, 4.047096352, 4.025100251, 3.561433345, 2.814193243, 3.637686431,
3.703703704, 3.450818054, 2.486749858, 6.237828616, 6.346020071, 3.120514261, 2.217304733,
1.572574304, 2.100840336, 5.385029618, 4.945598417, 3.311258278, 4.073319756, 3.162555345,
9.980017326), Ap = c(1L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 0L, 0L), Blocked = c(0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L,
0L, 1L, 1L, 0L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L,
0L, 1L, 1L, 999L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, 999L,
0L, 1L, 0L, 1L, 1L), Complexity = c(48L, 60L, 36L, 48L, 48L, 48L, 48L, 48L, 48L,
30L, 48L, 48L, 48L, 48L, 48L, 48L, 48L, 40L, 40L, 48L, 48L, 60L, 48L, 48L, 48L, 48L,
48L, 108L, 108L, 36L, 48L, 48L, 48L, 48L, 48L, 48L, 48L, 48L, 160L, 48L, 48L, 36L,
44L, 48L, 144L, 144L, 48L, 36L, 48L, 40L, 48L, 48L, 48L, 75L, 48L, 48L, 96L, 48L,
48L, 48L), PresTime = c(4, 999, 2.5, 8, 8, 5, 4.5, 6, 4, 4, 8, 2, 999, 8, 8, 999,
999, 4, 999, 4, 8, 4, 8, 4, 8.8, 8.8, 999, 999, 999, 3.5, 7, 2.5, 2.5, 8, 8, 8, 10,
14, 999, 999, 999, 999, 999, 999, 4, 4, 4, 999, 4, 999, 4, 4, 4, 4, 999, 4, 999,
8, 4, 4), DelDur = c(3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 3L, 3L, 4L, 4L,
4L, 4L, 4L, 8L, 4L, 4L, 4L, 4L, 3L, 4L, 4L, 3L, 3L, 3L, 4L, 5L, 4L, 4L, 4L, 4L, 4L,
3L, 3L, 5L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 3L, 999L, 4L, 3L, 3L, 3L, 3L, 3L, 5L, 3L,
3L, 4L, 3L, 3L), DistTask = c(3L, 3L, 1L, 1L, 1L, 2L, 2L, 1L, 2L, 2L, 4L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 1L, 3L, 1L, 1L, 1L, 1L, 1L, 3L, 3L, 1L, 1L, 1L,
1L, 1L, 4L, 4L, 1L, 4L, 4L, 4L, 4L, 4L, 1L, 1L, 1L, 1L, 4L, 1L, 2L, 2L, 2L, 2L, 1L,
1L, 3L, 1L, 1L, 2L)), .Names = c("HedgesG", "SE", "InverseSE", "Ap", "Blocked", "Complexity",
"PresTime", "DelDur", "DistTask"), class = "data.frame", row.names = c(NA, -60L))
# Code for Trim and Fill procedure, to fill in missing effect sizes.
tf1 <- trimfill(UT_CT$HedgesG, UT_CT$SE)
op <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
funnel(tf1, yaxis = "invse", xlab = "", ylab = "", contour = 0.95, xlim = c(-2, 2), ylim = c(1,
12), cex = 2, col = "black", col.contour = "lightgray", ref = 0, axes = F)
axis(1)
axis(2)
par(las = 0)
mtext("Hedges' G", side = 1, line = 2.5, cex = 1.5)
mtext("Inverse of Standard Error", side = 2, line = 3, cex = 1.5)
par(op)
12.2 Network Graph
Sacha Epskamp uses his qgraph package and shows how to display a network with nodes and connections.
library("psych")
library("qgraph")
# Load BFI data:
data(bfi)
bfi <- bfi[, 1:25]
# Groups and names object (not needed really, but make the plots easier to
# interpret):
Names <- scan("http://sachaepskamp.com/files/BFIitems.txt", what = "character", sep = "\n")
# Create groups object:
Groups <- rep(c("A", "C", "E", "N", "O"), each = 5)
# Compute correlations:
cor_bfi <- cor_auto(bfi)
# Plot correlation network:
graph_cor <- qgraph(cor_bfi, layout = "spring", nodeNames = Names, groups = Groups, legend.cex = 0.6,
DoNotPlot = TRUE)
# Plot partial correlation network:
graph_pcor <- qgraph(cor_bfi, graph = "concentration", layout = "spring", nodeNames = Names,
groups = Groups, legend.cex = 0.6, DoNotPlot = TRUE)
# Plot glasso network:
graph_glas <- qgraph(cor_bfi, graph = "glasso", sampleSize = nrow(bfi), layout = "spring",
nodeNames = Names, legend.cex = 0.6, groups = Groups, legend.cex = 0.7, GLratio = 2)
12.3 Questionnaire Graph
Sacha Epskamp shows how to present the many outcomes from a questionnaire in a single graph.
Show R-Codelibrary("psych")
library("qgraph")
# Load BFI data:
data(bfi)
bfi <- bfi[, 1:25]
# Groups and names object (not needed really, but make the plots easier to
# interpret):
Names <- scan("http://sachaepskamp.com/files/BFIitems.txt", what = "character", sep = "\n")
# Create groups object:
Groups <- rep(c("A", "C", "E", "N", "O"), each = 5)
# Compute correlations:
cor_bfi <- cor_auto(bfi)
# Plot correlation network:
graph_cor <- qgraph(cor_bfi, layout = "spring", nodeNames = Names, groups = Groups, legend.cex = 0.6,
DoNotPlot = TRUE)
# Plot partial correlation network:
graph_pcor <- qgraph(cor_bfi, graph = "concentration", layout = "spring", nodeNames = Names,
groups = Groups, legend.cex = 0.6, DoNotPlot = TRUE)
# Plot glasso network:
graph_glas <- qgraph(cor_bfi, graph = "glasso", sampleSize = nrow(bfi), layout = "spring",
nodeNames = Names, legend.cex = 0.6, groups = Groups, legend.cex = 0.7, GLratio = 2,
DoNotPlot = TRUE)
# centrality plot (all graphs):
centralityPlot(list(r = graph_cor, `Partial r` = graph_pcor, glasso = graph_glas),
labels = Names) + labs(colour = "") + theme_bw() + theme(legend.position = "bottom")
12.4 Heatmap with Contour Lines
This heatmap with contour lines displays the joint posterior for two variables.
Show R-Code### All Priming likelihood surface with posterior of uniform mu prior on top
# MCMC samples
load("samplesAllPriming_uniformMuPrior_SigmaTruncatedOnlyAtOne.Rdata")
samples <- samplesAllPriming_uniformMuPrior_SigmaTruncatedOnlyAtOne
posteriorMu <- samples$BUGSoutput$sims.list$muH1
posteriorPhi <- samples$BUGSoutput$sims.list$phi
library(ks)
d1 <- kde(cbind(posteriorMu, posteriorPhi))
# logLikelihood3d
load("logLikelihood3d_allPriming.Rdata")
ll <- logLikelihood3d_allPriming
likelihood <- exp(ll + 100)
sumLikelihood <- sum(likelihood)
weights <- likelihood/sumLikelihood
likelihoodTimesWeights <- likelihood * weights
averagedLikelihood <- apply(likelihoodTimesWeights, c(1, 2), sum)
mu <- seq(-6, 0, length.out = 200)
phi <- seq(0, 1, length.out = 200)
op <- par(mar = c(5, 5, 5, 5))
image(x = mu, y = phi, z = averagedLikelihood, col = topo.colors(12), xlab = "", ylab = "",
las = 1, cex.axis = 1.4)
mtext(expression(mu), 1, cex = 2.2, line = 2.55)
mtext(expression(phi), 2, cex = 2.35, line = 3.3, las = 1)
contour(x = d1$eval.points[[1]], y = d1$eval.points[[2]], z = d1$estimate, add = TRUE,
lty = 1)
mtext(expression("Priming Studies (N=268)"), side = 3, cex = 2, line = 0.7)
par(op)
12.5 Nonparametric Bayes
This plot shows the results of a nonparametric Bayesian Dirichlet process mixture model analysis. The left panel displays the distribution of “active” groups during the MCMC iterations, the right panel visualizes which observations were assigned to the same group (lighter colors indicate higher probabilities of being in the same group).
Show R-Code### plotting functions
.barplot <- function(column, variable, trueNgroups = 1, dontPlotData = FALSE) {
if (dontPlotData) {
plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE, xlab = "",
ylab = "")
axis(1, at = 0:1, labels = FALSE, cex.axis = 1.4, xlab = "")
axis(2, at = 0:1, labels = FALSE, cex.axis = 1.4, ylab = "")
mtext(text = variable, side = 1, cex = 1.5, line = 3)
return()
}
maxFrequency <- max(summary(column))
i <- 1
step <- 1
while (maxFrequency/step > 9) {
if (i == 2) {
step <- 2 * step
i <- i + 1
} else if (i%%3 == 0) {
step <- 2.5 * step
i <- i + 1
} else {
step <- 2 * step
i <- i + 1
}
}
yticks <- 0
while (yticks[length(yticks)] < maxFrequency) {
yticks <- c(yticks, yticks[length(yticks)] + step)
}
yLabs <- vector("character", length(yticks))
for (i in seq_along(yticks)) {
if (yticks[i] < 10^6) {
yLabs[i] <- format(yticks[i], digits = 3, scientific = FALSE)
} else {
yLabs[i] <- format(yticks[i], digits = 3, scientific = TRUE)
}
}
distLab <- max(nchar(yLabs))/1.8
par(mar = c(5, 7.2, 4, 2) + 0.1)
nGroups <- barplot(summary(column), cex.names = 1.3, axes = FALSE, ylim = range(yticks),
plot = FALSE)
col <- ifelse(seq_along(nGroups) == trueNgroups, "darkred", "grey")
barplot(summary(column), cex.names = 1.3, axes = FALSE, ylim = range(yticks), col = col)
axis(2, las = 1, at = yticks, labels = yLabs, cex.axis = 1.4)
mtext(text = variable, side = 1, cex = 1.5, line = 3)
mtext(text = "Frequency", side = 2, cex = 1.5, line = distLab + 2, las = 0)
}
plotCoocurrenceHeatMap <- function(coocurrenceProbs, offsetX = 0.3, offsetY = 0, cexXlab = 1.6,
cexYlab = 1.6, lwd = 4) {
parameterLabel1 <- "Observations"
parameterLabel2 <- "Observations"
op <- par(mar = c(5, 6, 3, 4) + 0.1, las = 1)
N <- ncol(coocurrenceProbs)
xRange <- c(0, N)
yRange <- c(0, N)
image(x = seq_len(N), y = seq_len(N), z = t(coocurrenceProbs), col = topo.colors(12),
xlab = "", ylab = "", las = 1, cex.axis = 1.2)
nRect <- N/50
for (nr in seq_len(nRect)) {
rect(1 + (nr - 1) * 50, 1 + (nr - 1) * 50, nr * 50, nr * 50, col = "darkred",
density = 0, lwd = lwd)
}
mtext(parameterLabel1, 1, cex = cexXlab, line = 2.5 + offsetX)
mtext(parameterLabel2, 2, cex = cexYlab, line = 3.2 + offsetY, las = 0)
par(op)
}
### 3 groups
load("samplesDPrecover3groups.Rdata")
load("coocurrenceProbs3.Rdata")
op <- par(mfrow = c(1, 2))
index3 <- paste("z[", seq_len(150), "]", sep = "")
zMatrix3 <- samplesDPrecover3groups$BUGSoutput$sims.matrix[, index3]
nGroupsPerIteration3 <- apply(zMatrix3, 1, function(x) length(unique(x)))
.barplot(as.factor(nGroupsPerIteration3), "Number of groups", trueNgroups = 1)
plotCoocurrenceHeatMap(coocurrenceProbs3)
par(op)
12.6 Confidence Band Plot
Courtesy of Liz Page-Gould, this plot shows how to plot a confidence band around a line.
Show R-Code#### Create Data #### Data compiled by Allan J. Rossman (1994) from The World Almanac
#### and Book of Facts, 1993
#### (http://www.amstat.org/publications/jse/v2n2/datasets.rossman.html)
life.expectancy <- c(70.5, 53.5, 65, 76.5, 70, 71, 60.5, 51.5, 78, 76, 57.5, 61, 64.5,
78.5, 79, 61, 70, 70, 72, 64.5, 54.5, 56.5, 64.5, 64.5, 73, 72, 69, 64, 78.5, 53,
75, 68.5, 70, 70.5, 76, 75.5, 74.5, 65)
ppl.per.tv <- c(4, 315, 4, 1.7, 8, 5.6, 15, 503, 2.6, 2.6, 44, 24, 23, 3.8, 1.8, 96,
90, 4.9, 6.6, 21, 592, 73, 14, 8.8, 3.9, 6, 3.2, 11, 2.6, 23, 3.2, 11, 5, 3, 3, 1.3,
5.6, 29)
# Centre predictor so prediction interval estimates can be determined from the
# intercept and its SE
c.ppl.per.tv <- ppl.per.tv - mean(ppl.per.tv)
#### Run the Omnibus Linear Model ####
linear.model <- glm(life.expectancy ~ c.ppl.per.tv)
#### Create Plot Data (Predicted Values Using Omnibus Model) ####
x <- seq(from = 0, to = max(ppl.per.tv))
y <- array(NA, dim = length(x))
y.upper <- y
y.lower <- y
for (i in 1:length(x)) {
raw.y <- coef(summary(update(linear.model, . ~ . - c.ppl.per.tv + eval(ppl.per.tv -
x[i]))))[1, 1]
raw.se <- coef(summary(update(linear.model, . ~ . - c.ppl.per.tv + eval(ppl.per.tv -
x[i]))))[1, 2]
y[i] <- raw.y
y.upper[i] <- raw.y + raw.se
y.lower[i] <- raw.y - raw.se
}
#### Create Plot ####
op <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5,
font.lab = 2, cex.axis = 1.5, bty = "n", las = 1)
plot(x, y, xlab = "", ylab = "", type = "n", xlim = c(0, max(x)), ylim = c(40, 80), axes = FALSE)
axis(1)
axis(2)
polygon(c(x, rev(x)), c(y.upper, rev(y.lower)), col = "lightsteelblue", border = NA)
lines(x, y, lwd = 2)
mtext("People Per TV", side = 1, line = 2.5, cex = 1.5)
mtext("Life Expectancy", side = 2, line = 3.7, cex = 1.5, las = 0)
12.7 Many Intervals in One Plot
Courtesy of Felix Schönbrodt and Maarten Marsman, this plot shows credible intervals for each of 42 experiments in the Social Psychology special issue. Each experiment tried to replicate an important result in the field of social psychology.
Show R-Code# rm (list = ls())
library(ggplot2)
clamp <- function(x, MIN, MAX) {
if (x < MIN)
x <- MIN
if (x > MAX)
x <- MAX
x
}
# these contain the necessary labels
x <- read.csv("all3.csv", sep = ";", header = TRUE)
# these contain the numeric values
bf <- read.csv("all3_bfs.csv", sep = ";", header = TRUE)
ALL <- data.frame(study = as.character(x$Study1), HPD.median = bf$HPD.median, HPD.upper = bf$HPD.upper,
HPD.lower = bf$HPD.lower, logBF10 = bf$logBF10, logBF10_clamped = sapply(bf$logBF10,
function(lbf) {
clamp(lbf, log(1/110), log(110))
}), test = as.character(x$Testtype), number = as.integer(x[, 1]))
rm(x, bf, clamp)
# reorder factor levels based on another variable (HPD.mean)
ALL$study.ES_order <- reorder(ALL$study, ALL$HPD.median, mean)
### Effect size plot
p <- ggplot(ALL[!is.na(ALL$HPD.median), ], aes(x = study.ES_order, y = HPD.median, ymin = HPD.lower,
ymax = HPD.upper)) + geom_pointrange() + theme_bw() + coord_flip() + geom_hline(yintercept = 0,
linetype = "dotted") + ylab("Posterior Effect Size (Unrestricted)") + xlab("")
# Some HPD intervals are missing (NA): These pertain to ANOVAS and Contingency
# tables, where there are multiple parameters per test.
print(p)
12.8 Many Bayes Factors in One Plot
Courtesy of Felix Schönbrodt and Maarten Marsman, this plot is similar to the one above but now presents the Bayes factor instead of the credible interval.
Show R-Code# rm(list = ls())
library(ggplot2)
clamp <- function(x, MIN, MAX) {
if (x < MIN)
x <- MIN
if (x > MAX)
x <- MAX
x
}
# these contain the necessary labels
x <- read.csv("all3.csv", sep = ";", header = TRUE)
# these contain the numeric values
bf <- read.csv("all3_bfs.csv", sep = ";", header = TRUE)
ALL <- data.frame(study = as.character(x$Study1), HPD.median = bf$HPD.median, HPD.upper = bf$HPD.upper,
HPD.lower = bf$HPD.lower, logBF10 = bf$logBF10, logBF10_clamped = sapply(bf$logBF10,
function(lbf) {
clamp(lbf, log(1/110), log(110))
}), test = as.character(x$Testtype), number = as.integer(x[, 1]))
rm(x, bf, clamp)
# reorder factor levels based on another variable (HPD.mean)
ALL$study.ES_order <- reorder(ALL$study, ALL$HPD.median, mean)
### BF plot
forH1 <- TRUE
fontsize <- 3.2
# reorder factor levels based on BF
ALL$study.BF_order <- reorder(ALL$study, ALL$logBF10, mean)
# reorder factor levels as in data frame
ALL$study.df_order <- factor(ALL$study, levels = rev(ALL$study))
# Define shape: Show an arrow if the BF has been clamped
ALL$shape <- "point"
ALL$shape[ALL$logBF10 > log(110)] <- "rightarrow"
ALL$shape[ALL$logBF10 < -log(110)] <- "leftarrow"
# Define size: < and > must be larger to be visible
ALL$size <- "small"
ALL$size[ALL$logBF10 > log(110)] <- "large"
ALL$size[ALL$logBF10 < -log(110)] <- "large"
p2 <- ggplot(ALL, aes(x = study.BF_order, y = logBF10_clamped)) + geom_point(aes(shape = shape,
size = size)) + theme_bw() + geom_hline(yintercept = 0, linetype = "dotted") + ylab("Bayes Factor") +
xlab("") + scale_shape_manual(guide = FALSE, values = c(60, 19, 62)) + scale_size_manual(guide = FALSE,
breaks = c("small", "large"), values = c(5, 2))
# All the annotation stuff ...
hlines <- c(-log(c(100, 30, 10, 3)), log(c(3, 10, 30, 100)))
p2 <- p2 + geom_hline(yintercept = hlines, linetype = "dotted", color = "darkgrey")
p2 <- p2 + geom_hline(yintercept = log(1), linetype = "dashed", color = "grey20")
p2 <- p2 + annotate("text", x = Inf, y = -5.15, label = paste0("~~Extreme~H[", ifelse(forH1 ==
TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE,
angle = 90)
p2 <- p2 + annotate("text", x = Inf, y = -4, label = paste0("~~Very~strong~H[", ifelse(forH1 ==
TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE,
angle = 90)
p2 <- p2 + annotate("text", x = Inf, y = -2.85, label = paste0("~~Strong~H[", ifelse(forH1 ==
TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE,
angle = 90)
p2 <- p2 + annotate("text", x = Inf, y = -1.7, label = paste0("~~Moderate~H[", ifelse(forH1 ==
TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE,
angle = 90)
p2 <- p2 + annotate("text", x = Inf, y = -0.55, label = paste0("~~Anectodal~H[", ifelse(forH1 ==
TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE,
angle = 90)
p2 <- p2 + annotate("text", x = Inf, y = 0.55, label = paste0("~~Anectodal~H[", ifelse(forH1 ==
TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, vjust = 0.5, size = fontsize, color = "black",
parse = TRUE, angle = 90)
p2 <- p2 + annotate("text", x = Inf, y = 5.15, label = paste0("~~Extreme~H[", ifelse(forH1 ==
TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE,
angle = 90)
p2 <- p2 + annotate("text", x = Inf, y = 4, label = paste0("~~Very~strong~H[", ifelse(forH1 ==
TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE,
angle = 90)
p2 <- p2 + annotate("text", x = Inf, y = 2.86, label = paste0("~~Strong~H[", ifelse(forH1 ==
TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE,
angle = 90)
p2 <- p2 + annotate("text", x = Inf, y = 1.7, label = paste0("~~Moderate~H[", ifelse(forH1 ==
TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE,
angle = 90)
# Add study type to right margin
p2 <- p2 + geom_text(aes(y = Inf, x = study.BF_order, label = test), size = 2, hjust = -0.1)
# set scale ticks
y_breaks <- c(c(-log(c(100, 30, 10, 3)), 0, log(c(3, 10, 30, 100))))
p2 <- p2 + scale_y_continuous(breaks = y_breaks, labels = c("1/100", "1/30", "1/10",
"1/3", "1", "3", "10", "30", "100"))
p2 <- p2 + coord_flip()
## Here comes the direty hack:
p2 <- p2 + theme(plot.margin = grid::unit(c(5, 5, 1, 1), "lines"))
# Code to override clipping, from
# http://stackoverflow.com/questions/10014187/displaying-text-below-the-plot-generated-by-ggplot2
gt <- ggplot_gtable(ggplot_build(p2))
gt$layout$clip[gt$layout$name == "panel"] <- "off"
grid::grid.draw(gt)
12.9 Prior and Posterior Distributions with Frills
This plot aims to explain the conclusions that can be drawn from a prior and a posterior distribution (background story: If Bob’s IQ is higher than 70 he will be executed). In a teaching setting it works best when the different elements (A-G) are visually introduced one at a time.
Show R-Code### prior & posterior parameters
mean.prior <- 75
sd.prior <- 12
mean.posterior <- 73.33644
sd.posterior <- 4.831067
### plot settings
xlim <- c(40, 115)
ylim <- c(0, 0.117)
lwd <- 2
lwd.points <- 2
lwd.axis <- 1.2
cex.points <- 1.4
cex.axis <- 1.2
cex.text <- 1.1
cex.labels <- 1.3
cexLegend <- 1.2
op <- par(mar = c(5.1, 4.1, 4.1, 2.1))
### create empty canvas
plot(1, xlim = xlim, ylim = ylim, axes = FALSE, xlab = "", ylab = "")
### shade prior area < 70
greycol1 <- rgb(0, 0, 0, alpha = 0.2)
greycol2 <- rgb(0, 0, 0, alpha = 0.4)
polPrior <- seq(xlim[1], 70, length.out = 400)
xx <- c(polPrior, polPrior[length(polPrior)], polPrior[1])
yy <- c(dnorm(polPrior, mean.prior, sd.prior), 0, 0)
polygon(xx, yy, col = greycol1, border = NA)
### shade posterior area < 70
polPosterior <- seq(xlim[1], 70, length.out = 400)
xx <- c(polPosterior, polPosterior[length(polPosterior)], polPosterior[1])
yy <- c(dnorm(polPosterior, mean.posterior, sd.posterior), 0, 0)
polygon(xx, yy, col = greycol2, border = NA)
### shade posterior area on interval (81, 84)
polPosterior2 <- seq(81, 84, length.out = 400)
xx <- c(polPosterior2, polPosterior2[length(polPosterior2)], polPosterior2[1])
yy <- c(dnorm(polPosterior2, mean.posterior, sd.posterior), 0, 0)
polygon(xx, yy, col = greycol2, border = NA)
### grey dashed lines to prior mean, posterior mean and posterior at 77
lines(rep(mean.prior, 2), c(0, dnorm(mean.prior, mean.prior, sd.prior)), lty = 2, col = "grey",
lwd = lwd)
lines(rep(mean.posterior, 2), c(0, dnorm(mean.posterior, mean.posterior, sd.posterior)),
lty = 2, col = "grey", lwd = lwd)
lines(rep(mean.posterior + (mean.posterior - 70), 2), c(0, dnorm(mean.posterior + (mean.posterior -
70), mean.posterior, sd.posterior)), lty = 2, col = "grey", lwd = lwd)
### axes
axis(1, at = seq(xlim[1], xlim[2], 5), cex.axis = cex.axis, lwd = lwd.axis)
axis(2, labels = FALSE, tck = 0, lwd = lwd.axis, line = -0.5)
### axes labels
mtext("IQ Bob", side = 1, cex = 1.6, line = 2.4)
mtext("Density", side = 2, cex = 1.5, line = 0)
### plot prior and posterior
# prior
plot(function(x) dnorm(x, mean.prior, sd.prior), xlim = xlim, ylim = ylim, xlab = "",
ylab = "", lwd = lwd, lty = 3, add = TRUE)
# posterior
plot(function(x) dnorm(x, mean.posterior, sd.posterior), xlim = xlim, ylim = ylim, add = TRUE,
lwd = lwd)
### add points
# posterior density at 70
points(70, dnorm(70, mean.posterior, sd.posterior), pch = 21, bg = "white", cex = cex.points,
lwd = lwd.points)
# posterior density at 76.67
points(mean.posterior + (mean.posterior - 70), dnorm(mean.posterior + (mean.posterior -
70), mean.posterior, sd.posterior), pch = 21, bg = "white", cex = cex.points, lwd = lwd.points)
# maximum a posteriori value
points(mean.posterior, dnorm(mean.posterior, mean.posterior, sd.posterior), pch = 21,
bg = "white", cex = cex.points, lwd = lwd.points)
### credible interval
CIlow <- qnorm(0.025, mean.posterior, sd.posterior)
CIhigh <- qnorm(0.975, mean.posterior, sd.posterior)
yCI <- 0.11
arrows(CIlow, yCI, CIhigh, yCI, angle = 90, code = 3, length = 0.1, lwd = lwd)
text(mean.posterior, yCI + 0.0042, labels = "95%", cex = cex.text)
text(CIlow, yCI, labels = paste(round(CIlow, 2)), cex = cex.text, pos = 2, offset = 0.3)
text(CIhigh, yCI, labels = paste(round(CIhigh, 2)), cex = cex.text, pos = 4, offset = 0.3)
### legend
legendPosition <- 115
legend(legendPosition, ylim[2] + 0.002, legend = c("Posterior", "Prior"), lty = c(1,
3), bty = "n", lwd = c(lwd, lwd), cex = cexLegend, xjust = 1, yjust = 1, x.intersp = 0.6,
seg.len = 1.2)
### draw labels
# A
arrows(x0 = 57, x1 = 61, y0 = dnorm(62, mean.prior, sd.prior) + 0.0003, y1 = dnorm(62,
mean.prior, sd.prior) - 0.007, length = c(0.08, 0.08), lwd = lwd, code = 2)
text(55.94, dnorm(5, mean.prior, sd.prior) + 0.0205, labels = "A", cex = cex.labels)
# B
arrows(x0 = 64.5, x1 = 69, y0 = dnorm(68, mean.posterior, sd.posterior) + 0.003, y1 = dnorm(68,
mean.posterior, sd.posterior) - 0.005, length = c(0.08, 0.08), lwd = lwd, code = 2)
text(63.5, dnorm(68, mean.posterior, sd.posterior) + 0.0042, labels = "B", cex = cex.labels)
# C
arrows(x0 = mean.posterior + 1, x1 = mean.posterior + 6, y0 = dnorm(mean.posterior, mean.posterior,
sd.posterior) + 0.001, y1 = dnorm(mean.posterior, mean.posterior, sd.posterior) +
0.008, length = c(0.08, 0.08), lwd = lwd, code = 1)
text(mean.posterior + 7, dnorm(mean.posterior, mean.posterior, sd.posterior) + 0.0093,
labels = "C", cex = cex.labels)
# D
arrows(x0 = 70 - 0.25, x1 = 70 - 0.25, y0 = dnorm(70, mean.posterior, sd.posterior) +
0.005, y1 = 0.092, length = c(0.08, 0.08), lwd = lwd, code = 1)
lines(c(70 - 0.25, mean.posterior), rep(0.092, 2), lwd = lwd)
arrows(x0 = mean.posterior, x1 = mean.posterior, y0 = 0.092, y1 = dnorm(mean.posterior,
mean.posterior, sd.posterior) + 0.003, length = c(0.08, 0.08), lwd = lwd, code = 2)
ratio <- dnorm(mean.posterior, mean.posterior, sd.posterior)/dnorm(70, mean.posterior,
sd.posterior)
text(mean(c(70 - 0.255, mean.posterior)), 0.096, labels = paste(round(ratio, 2), "x"),
cex = cex.text)
text(70 - 1.5, dnorm(70, mean.posterior, sd.posterior) + 0.02, labels = "D", cex = cex.labels)
# E
arrows(x0 = 70 + 1, x1 = mean.posterior + (mean.posterior - 70) - 1, y0 = dnorm(70, mean.posterior,
sd.posterior), y1 = dnorm(mean.posterior + (mean.posterior - 70), mean.posterior,
sd.posterior), length = c(0.08, 0.08), lwd = lwd, code = 3)
text(74.9, dnorm(mean.posterior + (mean.posterior - 70), mean.posterior, sd.posterior) -
0.005, labels = "E", cex = cex.labels)
# F
arrows(x0 = 82.5, x1 = 87, y0 = dnorm(82, mean.posterior, sd.posterior) - 0.012, y1 = dnorm(82,
mean.posterior, sd.posterior) - 0.005, length = c(0.08, 0.08), lwd = lwd, code = 1)
text(88, dnorm(82, mean.posterior, sd.posterior) - 0.0034, labels = "F", cex = cex.labels)
# G
arrows(x0 = CIhigh + 6, x1 = CIhigh + 8.2, y0 = yCI, y1 = yCI, length = c(0.08, 0.08),
lwd = lwd, code = 1)
text(CIhigh + 9.5, yCI, labels = "G", cex = cex.labels)
### additional information
scores <- "Bob's IQ scores: {73, 67, 79}"
priorText1 <- "Prior distribution:"
priorText2 <- expression(paste("IQ Bob ~ N(", 75, ", ", 12^2, ")"))
posteriorText1 <- "Posterior distribution:"
posteriorText2 <- expression(paste("IQ Bob ~ N(", 73.34, ", ", 4.83^2, ")"))
xx <- 87
yCI2 <- 0.12
text(xx, yCI2 - 0.033, labels = priorText1, cex = cexLegend, pos = 4, offset = 0.3)
text(xx, yCI2 - 0.042, labels = priorText2, cex = cexLegend, pos = 4, offset = 0.3)
text(xx, yCI2 - 0.059, labels = scores, cex = cexLegend, pos = 4, offset = 0.3)
text(xx, yCI2 - 0.074, labels = posteriorText1, cex = cexLegend, pos = 4, offset = 0.3)
text(xx, yCI2 - 0.083, labels = posteriorText2, cex = cexLegend, pos = 4, offset = 0.3)
par(op)
12.10 Heatmap Updating
The top row shows a sequence of heatmaps that describe a joint distribution; the bottom row shows the associated predictions. After every observation (the red cross), the heatmap is updated. As information flows in, from left to right, the heatmap becomes more concentrated and the predictions become more specific.
Show R-Code### joint prior density function
djointprior <- function(BobsTrueIQ, TestSD) {
dnorm(BobsTrueIQ, mean = 75, sd = 12) * 1/10 # 1/10 because TestSD \in (5,15)
}
### function that plots the joint prior
heatmap.prior <- function() {
op <- par(mar = c(5.1, 5.1, 5.1, 3.1))
BobsTrueIQ <- seq(40, 110, length.out = 151)
TestSD <- seq(5, 15, length.out = 151)
density <- outer(BobsTrueIQ, TestSD, djointprior)
image(x = BobsTrueIQ, y = TestSD, z = density, col = topo.colors(50), xlab = "",
ylab = "", axes = FALSE)
axis(1, at = seq(40, 110, 10), las = 1, cex.axis = 1.6)
axis(2, at = seq(5, 15, 2), las = 1, cex.axis = 1.6)
mtext("IQ Bob", 1, cex = 1.4, line = 2.75)
mtext("Test SD", 2, cex = 1.4, line = 2.8)
par(op)
}
### function that plots the joint posterior
library(ks)
heatmap.posterior <- function(samples) {
op <- par(mar = c(5.1, 5.1, 5.1, 3.1))
BobsTrueIQ <- samples$BUGSoutput$sims.list$BobsTrueIQ
TestSD <- samples$BUGSoutput$sims.list$TestSD
d <- kde(cbind(BobsTrueIQ, TestSD), xmin = c(40, 5), xmax = c(110, 15))
image(x = d$eval.points[[1]], y = d$eval.points[[2]], z = d$estimate, col = topo.colors(50),
xlab = "", ylab = "", axes = FALSE)
axis(1, at = seq(40, 110, 10), las = 1, cex.axis = 1.6)
axis(2, at = seq(5, 15, 2), las = 1, cex.axis = 1.6)
mtext("IQ Bob", 1, cex = 1.4, line = 2.75)
mtext("Test SD", 2, cex = 1.4, line = 2.8)
par(op)
}
### function that plots the predictive data distribution
plot.predictive <- function(samples, prior = FALSE, xlim = c(15, 135), ylim = c(0, 0.36),
lwd = 2, lwd.axis = 1, cex.axis = 1.6) {
if (prior) {
pred <- samples$BUGSoutput$sims.list$BobsIQScoresPriorPred
} else {
pred <- samples$BUGSoutput$sims.list$BobsIQScoresPostPred
}
mean.pred <- mean(pred)
sd.pred <- sd(pred)
### plot settings
op <- par(mar = c(5.1, 5.1, 5.1, 3.1))
### create empty canvas
plot(1, xlim = xlim, ylim = ylim, axes = FALSE, xlab = "", ylab = "")
plot(function(x) dnorm(x, mean.pred, sd.pred), xlim = xlim, ylim = ylim, xlab = "",
ylab = "", lwd = lwd, add = TRUE)
### axes
axis(1, at = seq(15, 135, 20), cex.axis = cex.axis, lwd = lwd.axis)
axis(2, at = ylim, labels = FALSE, tck = 0, lwd = lwd.axis)
### axes labels
mtext("Predicted IQ Scores", side = 1, cex = 1.4, line = 2.75)
mtext("Density", side = 2, cex = 1.4, line = 0.8)
par(op)
}
########################## 8-panel plot ##
### load samples
load(file = "samplesBob1.Rdata")
load(file = "samplesBob2.Rdata")
load(file = "samplesBob3.Rdata")
### plot
op <- par(mfrow = c(2, 4), xpd = NA)
heatmap.prior()
arrows(x0 = 75, x1 = 75, y0 = 2, y1 = -1, length = c(0.2, 0.2), lwd = 3, code = 2)
arrows(x0 = 95, x1 = 125, y0 = -1, y1 = 2, length = c(0.2, 0.2), lwd = 3, code = 2)
heatmap.posterior(samplesBob1)
arrows(x0 = 75, x1 = 75, y0 = 2, y1 = -1, length = c(0.2, 0.2), lwd = 3, code = 2)
arrows(x0 = 95, x1 = 125, y0 = -1, y1 = 2, length = c(0.2, 0.2), lwd = 3, code = 2)
heatmap.posterior(samplesBob2)
arrows(x0 = 75, x1 = 75, y0 = 2, y1 = -1, length = c(0.2, 0.2), lwd = 3, code = 2)
arrows(x0 = 95, x1 = 125, y0 = -1, y1 = 2, length = c(0.2, 0.2), lwd = 3, code = 2)
heatmap.posterior(samplesBob3)
arrows(x0 = 75, x1 = 75, y0 = 2, y1 = -1, length = c(0.2, 0.2), lwd = 3, code = 2)
plot.predictive(samplesBob1, prior = TRUE, ylim = c(0, 0.027))
points(73, 0.0005, col = "darkred", pch = 4, cex = 1.6, lwd = 3)
plot.predictive(samplesBob1, ylim = c(0, 0.034))
points(73, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(67, 0.0005, col = "darkred", pch = 4, cex = 1.6, lwd = 3)
plot.predictive(samplesBob2, ylim = c(0, 0.038))
points(73, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(67, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(79, 0.0005, col = "darkred", pch = 4, cex = 1.6, lwd = 3)
plot.predictive(samplesBob3, ylim = c(0, 0.041))
points(73, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(67, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(79, 0.0005, pch = 4, cex = 1.6, lwd = 3)
par(op)
12.11 Meta-Analytic Forest Plot
This graph contains a lot of information: study number, raw summary data, mean effect size, 95% confidence intervals, and a meta-analytic estimate. Importantly, the broad picture can be obtained from a brief look at the intervals, whereas the numbers allow a more detailed analysis.
Show R-Codeload("metaG.Rdata")
g <- c(-0.35, -0.67, -0.25, -0.22, -0.22, -0.36, -0.67, -0.25, -0.22, -0.22, -0.36, -0.22,
-0.67, -0.25, -0.22, -0.36, -0.67, -0.25, -0.22, -0.22, -0.36)
gSE <- c(0.469041575982343, 0.469041575982343, 0.458257569495584, 0.458257569495584,
0.458257569495584, 0.458257569495584, 0.469041575982343, 0.458257569495584, 0.458257569495584,
0.458257569495584, 0.458257569495584, 0.458257569495584, 0.469041575982343, 0.458257569495584,
0.458257569495584, 0.458257569495584, 0.469041575982343, 0.458257569495584, 0.458257569495584,
0.458257569495584, 0.458257569495584)
cMeanSmile <- c("3.48", "3.75", "3.48", "3.67", "3.60", "3.58", "3.75", "3.48", "3.67",
"3.60", "3.58", "3.67", "3.75", "3.48", "3.60", "3.58", "3.75", "3.48", "3.67", "3.60",
"3.58")
cMeanPout <- c("3.96", "4.81", "3.81", "3.94", "3.88", "4.03", "4.81", "3.81", "3.94",
"3.88", "4.03", "3.94", "4.81", "3.81", "3.88", "4.03", "4.81", "3.81", "3.94", "3.88",
"4.03")
forest(x = g, sei = gSE, xlab = "Hedges' g", cex.lab = 1.4, ilab = cbind(cMeanSmile,
cMeanPout), ilab.xpos = c(-3.2, -2.5), cex.axis = 1.1, mlab = "Meta-Analytic Effect:",
lwd = 1.4, rows = 22:2, addfit = FALSE, atransf = FALSE, ylim = c(-2, 25))
text(-4.05, 24, "Study", cex = 1.3)
text(-3.2, 24, "Smile", cex = 1.3)
text(-2.5, 24, "Pout", cex = 1.3)
text(2.75, 24, "Hedges' g [95% CI]", cex = 1.3)
abline(h = 1, lwd = 1.4)
addpoly(metaG, atransf = FALSE, row = -1, cex = 1.3, mlab = "Meta-Analytic Effect Size:")
12.12 Many Bayes Factors with Zoom
This two-panel plot presents replication Bayes factors (Verhagen & Wagenmakers, 2014) for the experiments in the “pipeline project” (Schweinsberg et al., in press). The problem that this graph seeks to overcome is that some Bayes factors are very large, extending the scale on the x-axis and making it impossible to discern what happens in the interesting region where the evidence is less compelling. Therefore, the bottom panel zooms in on the area of interest. This fact is evident from the grey area that spreads out from the top panel to the lower panel.
Show R-Code############################### @ plot replication BFs @##
load("logRepBFs.Rdata")
load("scaleBF.Rdata")
load("scaleBF2.Rdata")
load("indices.Rdata")
studies <- c("MoralInversion", "BadTipper", "BeliefInconsistency", "MoralCliff", "ColdHearted", "BurnInHell", "Biggot", "PresumptionOfGuilt", "intuitiveEconomics",
"HigherCompany", "higherCharity")
op <- par(mar = c(4, 26, 1, 4), mfrow = c(2, 1))
plot(1, xlim = scaleBF$lim, ylim = c(0, 12), type = "n", axes = FALSE, xlab = "", ylab = "")
lines(rep(0, 2), c(0.5, 11), lty = 2, lwd = 2)
greycol <- rgb(0, 0, 0, alpha = 0.2)
rect(xleft = log(1/100), ybottom = 0.5, xright = log(100), ytop = 11, lwd = 2, col = greycol, border = NA)
y <- 11
for (study in studies) {
points(logRepBFs[[study]], rep(y, length(logRepBFs[[study]])), pch = 21, bg = "grey", cex = 1.5, lwd = 1.3)
y <- y - 1
}
axis(1, at = scaleBF$at, labels = scaleBF$lab, cex.axis = 1.4, lwd = 1.4, line = -1.5)
axis(2, at = 1:11, labels = NA, las = 1, cex.axis = 1.4, lwd = 1.4)
axis(2, at = 11, labels = expression(paste("Moral Inversion ", (BF[1][0] == 7.526))), las = 1, cex.axis = 1.4)
axis(2, at = 10, labels = expression(paste("Bad Tipper ", (BF[1][0] == 5.525))), las = 1, cex.axis = 1.4)
axis(2, at = 9, labels = expression(paste("Belief-Act Inconsistency ", (BF[1][0] == 1.119))), las = 1, cex.axis = 1.4)
axis(2, at = 8, labels = expression(paste("Moral Cliff ", (BF[1][0] == 3.084 %*% 10^7))), las = 1, cex.axis = 1.4)
axis(2, at = 7, labels = expression(paste("Cold Hearted Prosociality ", (BF[1][0] == 4.155 %*% 10^24))), las = 1, cex.axis = 1.4)
axis(2, at = 6, labels = expression(paste("Burn in Hell ", (BF[1][0] == 3.031))), las = 1, cex.axis = 1.4)
axis(2, at = 5, labels = expression(paste("Bigot-Misanthrope ", (BF[1][0] == 61465))), las = 1, cex.axis = 1.4)
axis(2, at = 4, labels = expression(paste("Presumption of Guilt ", (BF[0][1] == 5.604))), las = 1, cex.axis = 1.4)
axis(2, at = 3, labels = expression(paste("Intuitive Economics ", (BF[1][0] == 7.454 %*% 10^6))), las = 1, cex.axis = 1.4)
axis(2, at = 2, labels = expression(paste("Higher Standards-Company ", (BF[0][1] == 1.781))), las = 1, cex.axis = 1.4)
axis(2, at = 1, labels = expression(paste("Higher Standards-Charity ", (BF[1][0] == 131.7))), las = 1, cex.axis = 1.4)
mtext(expression(BF["r"]["0"]), side = 1, line = 1.6, cex = 1.7)
## zoom-in ##
plot(1, xlim = scaleBF2$lim, ylim = c(0, 12), type = "n", axes = FALSE, xlab = "", ylab = "")
rect(xleft = log(1/100), ybottom = 0.5, xright = log(100), ytop = 11.2, lwd = 2, col = greycol, border = greycol, density = NA)
y <- 11
lines(rep(0, 2), c(0.5, 11), lty = 2, lwd = 2)
for (study in studies) {
points(logRepBFs[[study]][indices[[study]]], rep(y, length(logRepBFs[[study]][indices[[study]]])), pch = 21, bg = "grey", cex = 1.5, lwd = 1.3)
y <- y - 1
}
axis(1, at = scaleBF2$at, labels = scaleBF2$lab, cex.axis = 1.4, lwd = 1.2, line = -1.5)
axis(2, at = 1:11, labels = NA, las = 1, cex.axis = 1.4, lwd = 1.4)
axis(2, at = 11, labels = expression(paste("Moral Inversion ", (BF[1][0] == 7.526))), las = 1, cex.axis = 1.4)
axis(2, at = 10, labels = expression(paste("Bad Tipper ", (BF[1][0] == 5.525))), las = 1, cex.axis = 1.4)
axis(2, at = 9, labels = expression(paste("Belief-Act Inconsistency ", (BF[1][0] == 1.119))), las = 1, cex.axis = 1.4)
axis(2, at = 8, labels = expression(paste("Moral Cliff ", (BF[1][0] == 3.084 %*% 10^7))), las = 1, cex.axis = 1.4)
axis(2, at = 7, labels = expression(paste("Cold Hearted Prosociality ", (BF[1][0] == 4.155 %*% 10^24))), las = 1, cex.axis = 1.4)
axis(2, at = 6, labels = expression(paste("Burn in Hell ", (BF[1][0] == 3.031))), las = 1, cex.axis = 1.4)
axis(2, at = 5, labels = expression(paste("Bigot-Misanthrope ", (BF[1][0] == 61465))), las = 1, cex.axis = 1.4)
axis(2, at = 4, labels = expression(paste("Presumption of Guilt ", (BF[0][1] == 5.604))), las = 1, cex.axis = 1.4)
axis(2, at = 3, labels = expression(paste("Intuitive Economics ", (BF[1][0] == 7.454 %*% 10^6))), las = 1, cex.axis = 1.4)
axis(2, at = 2, labels = expression(paste("Higher Standards-Company ", (BF[0][1] == 1.781))), las = 1, cex.axis = 1.4)
axis(2, at = 1, labels = expression(paste("Higher Standards-Charity ", (BF[1][0] == 131.7))), las = 1, cex.axis = 1.4)
mtext(expression(BF["r"]["0"]), side = 1, line = 1.6, cex = 1.7)
par(xpd = NA)
polygon(x = c(log(1/100), log(1/42.5), log(1/38.5), log(100), log(1/100)), y = c(11.2, 15.63, 15.63, 11.2, 11.2), col = greycol, border = NA)
par(op)
12.13 Reproducibility Project: The Correlation Graph
Courtesy of Fred Hasselman, this graph is a slightly edited version of the one that was prominently displayed in a groundbreaking publication (Open Science Collaboration, 2015). The associated information on the Open Science Framework is here. You may compare versions – what has changed?
Show R-Code# SETUP local R-------------------------------------------------------------------
library(grid)
# Use this code (from the devtools package) to source C-3PR directly from GitHub:
library(devtools)
source_url('https://raw.githubusercontent.com/FredHasselman/toolboxR/master/C-3PR.R')
# This will load and (if necessary) install libraries frequently used for data management and plotting
in.IT(c('ggplot2','RColorBrewer','lattice','gridExtra','plyr','dplyr','httr'))
RPPdata<-read.csv('rpp_data.csv',stringsAsFactors=F )
RPPdata<-df.Clean(RPPdata)
RPPdata<-RPPdata$df
# Select the completed replication studies
RPPdata <- dplyr::filter(RPPdata, !is.na(T.pval.USE.O),!is.na(T.pval.USE.R))
# We have 99 studies for which p-values and effect sizes could be calculated
nrow(RPPdata)
# We have 97 studies for which p-values of the original effect were significantly below .05
idOK <- complete.cases(RPPdata$T.r.O,RPPdata$T.r.R)
# sum(idOK)
# Get ggplot2 themes predefined in C-3PR
mytheme <- gg.theme("clean")
# Get the Replication observed power
RPPdata$Power.Rn <- as.numeric(RPPdata$Power.R)
########################
# FIGURE 3
# EFFECT SIZE DENSITY PLOTS -------------------------------------------------------------
########################
# Setup some variables
RPPdata$oriSig <- "Not Significant"
# 3 studies claimed an effect at .05 < p < .06
RPPdata$oriSig[RPPdata$T.pval.USE.O<=.06] <- "Significant"
RPPdata$oriSig <- factor(RPPdata$oriSig)
RPPdata$repSig <- "Not Significant"
RPPdata$repSig[RPPdata$T.pval.USE.R<=.05] <- "Significant"
RPPdata$repSig <- factor(RPPdata$repSig)
RPPdata$repSig <- factor(RPPdata$repSig)
# Create a scatterplot with density margin plots
# The plotHolder() function from C-3PR creates a blank plot template that will hold the figures
blankPlot <- plotHolder()
# X margin density plot (note: gg.theme() from C-3PR can be used directly in a ggplot2() call)
xDense <- ggplot(RPPdata, aes(x=T.r.O, fill=oriSig)) +
geom_density(aes(y= ..count..),trim=F,alpha=.5) +
xlab("") + ylab("") + xlim(0,1) +
gg.theme("noax") +
theme(legend.position = "none",plot.margin = unit(c(0,0,0,4), "lines"))
## Uncomment to save subplot
# ggsave("RPP_F3_xDense.png",plot=xDense)
# Y margin density plot (note: gg.theme() from C-3PR can be used directly in a ggplot2() call)
yDense <- ggplot(RPPdata, aes(x=T.r.R, fill=repSig)) +
geom_density(aes(y= ..count..),trim=F,alpha=.5) +
xlab("") + ylab("") + xlim(-.5,1) +
coord_flip() +
gg.theme("noax") +
theme(legend.position = "none", plot.margin = unit(c(0,0,3,0), "lines"))
## Uncomment to save subplot
# ggsave("RPP_F3_yDense.png",plot=yDense)
# The main scatterplot (note: gg.theme() from C-3PR can be used directly in a ggplot2() call)
scatterP<-
ggplot(RPPdata,aes(x=T.r.O,y=T.r.R)) +
geom_hline(aes(yintercept=0),linetype=2) +
geom_abline(intercept=0,slope=1,color="Grey60")+
geom_point(aes(size=Power.Rn,fill=repSig),color="Grey30",shape=21,alpha=.8) +
geom_rug(aes(color=oriSig),size=1,sides="b",alpha=.6) +
geom_rug(aes(color=repSig),,size=1,sides="l",alpha=.6) +
scale_x_continuous(name="Original Effect Size",limits=c(0,1),breaks=c(0,.25,.5,.75,1)) +
scale_y_continuous(name="Replication Effect Size",limits=c(-.5,1),breaks=c(-.5,-.25,0,.25,.5,.75,1)) +
ggtitle("") + xlab("") + ylab("") +
scale_size_continuous(name="Replication Power",range=c(2,9)) +
scale_color_discrete(name="p-value") +
scale_fill_discrete(name="p-value") +
gg.theme("clean") +
theme(legend.position=c(.87,.185), legend.text=element_text(size=16), legend.title=element_text(size=18), plot.margin = unit(c(-2,-1.5,2,2), "lines"), axis.text.x=element_text(size=20), axis.text.y=element_text(size=20), axis.title.x=element_text(size=25, vjust=-1.6), axis.title.y=element_text(size=26, vjust=2.6))
## Uncomment to save subplot
# ggsave("RPP_F3_scatter.png",plot=scatterP)
# Yet another way to organise plots: grid.arrange() from the gridExtra package.
grid.arrange(xDense, blankPlot, scatterP, yDense, ncol=2, nrow=2, widths=c(4, 1.4), heights=c(1.4, 4))
12.14 Reproducibility Project: The Layered-Violin Graph
Courtesy of Fred Hasselman, this is a slightly edited version of a plot for the Reproducibility Project. The graph shows violin plots for p-values (left panel) and effect-sizes (right panel). Note that the violin plot is divided into four areas.
Show R-Code######################################################################################
# RPP Manuscript Figure 1 (ViolinQtilePlots) #
# #
# Created by [Fred Hasselman](https://osf.io/ujgs6/) on behalf of the RPP intiative #
######################################################################################
# FUNCTIONS ---------------------------------------------------------------
## GET DATA
df.Clean <- function(df,Sep="."){
nms <- colnames(df)
rws <- rownames(df)
# Change punctuation and blankss in variable names to points
nmsP <- gsub("([[:punct:]]|[[:blank:]])+","+",nms)
nmsPP <- gsub("(^[+]|[+]$)+","",nmsP)
nmsPP <- gsub("[+]",Sep,nmsPP)
# Check for double names
ifelse(length(unique(nmsPP))==length(nmsPP),{nms <- nmsPP},{
id2 <- which(plyr::laply(nmsPP,function(n) sum(nmsPP%in%n))>1)
nms <- nmsPP
nms[id2] <- paste(nmsPP[id2],id2,sep=".")})
colnames(df) <- nms
df <- dplyr::select(df,which(nms%in%nms[nms!=""]))
df[ ,1] <- paste0("Row.",seq(1,nrow(df)))
colnames(df)[1] <- paste("Local","ID",sep=Sep)
return(list(df=df,
nms=nms,
rws=rws))
}
get.OSFfile <- function(# Function to download OSF file modified from code by Sacha Epskamp
code, #Either "https://osf.io/XXXXX/" or just the code
dir = tempdir(), # Output location
scanMethod, # "readLines" or "RCurl". Leave missing to automatically chose
downloadMethod = c("httr","downloader","curl"), # First one is chosen
dataFrame = TRUE,
sep = ',',
dfCln = FALSE
){
# Check if input is code:
if (!grepl("osf\\.io",code)){
URL <- sprintf("https://osf.io/%s/",code)
} else URL <- code
# Scan page:
if (grepl("Windows",Sys.info()[['sysname']],ignore.case=TRUE)){
try(setInternet2(TRUE))
}
if (missing(scanMethod)){
scanMethod <- ifelse(grepl("Windows",Sys.info()[['sysname']],ignore.case=TRUE), "readLines", "RCurl")
}
if (scanMethod == "readLines"){
Page <- paste(readLines(URL),collapse="\n")
} else if (scanMethod == "RCurl"){
library("RCurl")
Page <- RCurl::getURL(URL)
} else if (scanMethod == "httr"){
Page <- httr::GET(URL)
Page <- paste(Page,collapse="\n")
} else stop("Invalid scanMethod")
# Create download link:
URL <- gsub("/$","",URL)
# Link <- paste0(URL,"/?action=download&version=1")
Link <- paste0(URL,"/?action=download")
# Extract file name:
FileName <- regmatches(Page,gregexpr("(?<=\\OSF \\| ).*?(?=\\ )", Page, perl=TRUE))[[1]]
FullPath <- paste0(dir,"/",FileName)
info <- NULL
# Download file:
if (downloadMethod[[1]]=="httr"){
library("httr")
info <- httr::GET(Link, httr::write_disk(FullPath, overwrite = TRUE))
} else if (downloadMethod[[1]]=="downloader"){
library("downloader")
downloader:::download(Link, destfile = FullPath, quiet=TRUE)
} else if (downloadMethod[[1]]=="curl"){
system(sprintf("curl -J -L %s > %s", Link, FullPath), ignore.stderr = TRUE)
} else stop("invalid downloadMethod")
df <- NULL
if(dataFrame==TRUE){
if(grepl('xls',FileName)){
df <- tbl_df(read.xlsx2(file=FullPath,sheetIndex=1))
} else {
df <- tbl_df(read.table(FullPath,stringsAsFactors=F,fill = T,header=T,sep=sep, comment.char = "",quote = "\""))
}
if(dfCln==TRUE){df <- df.Clean(df)} else {df$df <- df}
return(list(df = df$df,
info = list(FilePath=FullPath,
Info=info,
ori.Colnames=tbl_df(data.frame(ori.colnames=df$nms)),
ori.Rownames=tbl_df(data.frame(ori.rownames=df$rws))
)))
} else {
# Return location of file:
return(FilePath=FullPath)
}
}
## PLOTS
gg.theme <- function(type=c("clean","noax")[1],useArial = F, afmPATH="~/Dropbox"){
require(ggplot2)
if(useArial){
set.Arial(afmPATH)
bf_font="Arial"
} else {bf_font="Helvetica"}
switch(type,
clean = theme_bw(base_size = 16, base_family=bf_font) +
theme(axis.text.x = element_text(size = 14),
axis.title.y = element_text(vjust = +1.5),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
legend.background = element_blank(),
legend.key = element_blank(),
panel.border = element_blank(),
panel.background = element_blank(),
axis.line = element_line(colour = "black")),
noax = theme(line = element_blank(),
text = element_blank(),
title = element_blank(),
plot.background = element_blank(),
panel.border = element_blank(),
panel.background = element_blank())
)
}
set.Arial <- function(afmPATH="~/Dropbox"){
# Set up PDF device on MAC OSX to use Arial as a font in Graphs
if(nchar(afmPATH>0)){
if(file.exists(paste0(afmPATH,"/Arial.afm"))){
Arial <- Type1Font("Arial",
c(paste(afmPATH,"/Arial.afm",sep=""),
paste(afmPATH,"/Arial Bold.afm",sep=""),
paste(afmPATH,"/Arial Italic.afm",sep=""),
paste(afmPATH,"/Arial Bold Italic.afm",sep="")))
if(!"Arial" %in% names(pdfFonts())){pdfFonts(Arial=Arial)}
if(!"Arial" %in% names(postscriptFonts())){postscriptFonts(Arial=Arial)}
return()
} else {disp(header='useArial=TRUE',message='The directory did not contain the *.afm version of the Arial font family')}
} else {disp(header='useArial=TRUE',message='Please provide the path to the *.afm version of the Arial font family')}
}
#function to create geom_ploygon calls
fill_viol<-function(gr.df,gr,qtile,probs){
# SETUP VIOLIN QUANTILE PLOTS -----------------------------------
# This is adapted from: http://stackoverflow.com/questions/22278951/combining-violin-plot-with-box-plot
ifelse(is.null(qtile),{
cuts <- cut(gr.df$y, breaks = quantile(gr.df$y, probs, na.rm=T, type=3, include.lowest = T, right = T), na.rm=T)},{
cuts <- cut(gr.df$y, breaks = qtile, na.rm=T)
}
)
quants <- mutate(gr.df,
x.l=x-violinwidth/2,
x.r=x+violinwidth/2,
cuts=cuts)
plotquants <- data.frame(x=c(quants$x.l,rev(quants$x.r)),
y=c(quants$y,rev(quants$y)),
id=c(quants$cuts,rev(quants$cuts)))
#cut by quantile to create polygon id
geom <- geom_polygon(aes(x=x,y=y,fill=factor(id)),data=plotquants,alpha=1)
return(list(quants=quants,plotquants=plotquants,geom=geom))
}
vioQtile <- function(gg=NULL,qtiles=NULL,probs=seq(0,1,.25),labels=paste(probs[-1]*100),withData=FALSE){
require(ggplot2)
# SETUP VIOLIN QUANTILE PLOTS -----------------------------------
# This is adapted from: http://stackoverflow.com/questions/22278951/combining-violin-plot-with-box-plot
#
# Changed:
# - Deal with 'empty' quantile groups
# - Deal with original data
# - More input, more output
g.df <- ggplot_build(gg)$data[[1]] # use ggbuild to get the outline co-ords
ifelse(is.null(qtiles),{
gg <- gg + lapply(unique(g.df$group), function(x) fill_viol(g.df[g.df$group==x, ],x,NULL,probs)$geom)},{
gg <- gg + lapply(unique(g.df$group), function(x) fill_viol(g.df[g.df$group==x, ],x,qtiles[x, ],probs)$geom)}
)
gg <- gg + geom_hline(aes(yintercept=0)) +
scale_fill_grey(name="Quantile\n",labels=labels,guide=guide_legend(reverse=T,label.position="right")) +
stat_summary(fun.y=median, geom="point", size=8, color="grey80",shape=21,fill="white")
if(withData){
ifelse(is.null(qtiles),{
ggData <- lapply(unique(g.df$group), function(x) fill_viol(g.df[g.df$group==x,],x,NULL,probs))},{
ggData <- lapply(unique(g.df$group), function(x) fill_viol(g.df[g.df$group==x,],x,qtiles[x,],probs))
}
)
return(list(ggGraph=gg,ggData=ggData))
} else {
return(gg)
}
}
# MULTIPLOT FUNCTION ------------------------------------------------------------------------------------------------------------------
#
# [copied from http://www.cookbook-r.com/Graphs/Multiple_graphs_on_one_page_(ggplot2)/ ]
#
# ggplot objects can be passed in ..., or to plotlist (as a list of ggplot objects)
# - cols: Number of columns in layout
# - layout: A matrix specifying the layout. If present, 'cols' is ignored.
#
# If the layout is something like matrix(c(1,2,3,3), nrow=2, byrow=TRUE),
# then plot 1 will go in the upper left, 2 will go in the upper right, and
# 3 will go all the way across the bottom.
#
multi.PLOT <- function(..., plotlist=NULL, file, cols=1, layout=NULL) {
require(grid)
# Make a list from the ... arguments and plotlist
plots <- c(list(...), plotlist)
numPlots = length(plots)
# If layout is NULL, then use 'cols' to determine layout
if (is.null(layout)) {
# Make the panel
# ncol: Number of columns of plots
# nrow: Number of rows needed, calculated from # of cols
layout <- matrix(seq(1, cols * ceiling(numPlots/cols)),
ncol = cols, nrow = ceiling(numPlots/cols))
}
if (numPlots==1) {
print(plots[[1]])
} else {
# Set up the page
grid.newpage()
pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout))))
# Make each plot, in the correct location
for (i in 1:numPlots) {
# Get the i,j matrix positions of the regions that contain this subplot
matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE))
print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row,
layout.pos.col = matchidx$col))
}
}
}
# MAIN CODE ---------------------------------------------------------------
# SETUP local R-------------------------------------------------------------------
require('ggplot2')
require('RColorBrewer')
require('lattice')
require('gridExtra')
require('plyr')
require('dplyr')
require('httr')
require('RCurl')
# Read the data from the OSF storage
# Note: get.OSFfile() returns a list with the .csv data (df) and information (info) containing the URL download timestamp and original column and rownames (these names will be changed if dfCln=TRUE).
RPPdata <- get.OSFfile(code='https://osf.io/fgjvw/',dfCln=T)$df
## If you dowloaded the csv file to your harddrive use this code:
# RPPdata<-read.csv('rpp_data.csv',stringsAsFactors=F )
# RPPdata<-df.Clean(RPPdata)
# RPPdata<-RPPdata$df
# Select the completed replication studies
RPPdata <- dplyr::filter(RPPdata, !is.na(T.pval.USE.O),!is.na(T.pval.USE.R))
# We have 99 studies for which p-values and effect sizes could be calculated
nrow(RPPdata)
# We have 97 studies for which p-values of the original effect were significantly below .05
idOK <- complete.cases(RPPdata$T.r.O,RPPdata$T.r.R)
sum(idOK)
# Get ggplot2 themes predefined in C-3PR
mytheme <- gg.theme("clean")
############
# FIGURE 1
# VIOLIN QUANTILE PLOTS (VQP) -----------------------------------------------
############
# Restructure the data to "long" format: Study type will be a factor
df <- dplyr::select(RPPdata,starts_with("T."))
df <- data.frame(EffectSize=as.numeric(c(df$T.r.O,df$T.r.R)),p.value=as.numeric(c(df$T.pval.USE.O,df$T.pval.USE.R)),grp=factor(c(rep("Original Studies",times=length(df$T.r.O)),rep("Replications",times=length(df$T.r.R)))))
# Create some variables for plotting
df$grpN <- as.numeric(df$grp)
probs <- seq(0,1,.25)
# VQP PANEL A: p-value -------------------------------------------------
# Get p-value quantiles and frequencies from data
qtiles <- ldply(unique(df$grpN),function(gr) quantile(round(df$p.value[df$grpN==gr],digits=4),probs,na.rm=T,type=3))
freqs <- ldply(unique(df$grpN),function(gr) table(cut(df$p.value[df$grpN==gr],breaks=qtiles[gr,],na.rm=T,include.lowest=T,right=T)))
labels <- sapply(unique(df$grpN),function(gr)levels(cut(round(df$p.value[df$grpN==gr],digits=4), breaks = qtiles[gr,],na.rm=T,include.lowest=T,right=T)))
# Get regular violinplot using package ggplot2
g.pv <- ggplot(df,aes(x=grp,y=p.value)) + geom_violin(aes(group=grp),scale="width",color="grey30",fill="grey30",trim=T,adjust=.7)
# Cut at quantiles using vioQtile() in C-3PR
g.pv0 <- vioQtile(g.pv,qtiles,probs)
# Garnish
g.pv1 <- g.pv0 + geom_hline(aes(yintercept=.05),linetype=2) +
ggtitle("A") + xlab("") + ylab("p-value") +
mytheme + theme(legend.position=c(.5,.5), legend.text=element_text(size=20), legend.title=element_text(size=22), axis.text.x=element_text(size=26), axis.text.y=element_text(size=22), axis.title.y=element_text(size=30, vjust=2.6), title=element_text(size=27))
# View
g.pv1
## Uncomment to save panel A as a seperate file
# ggsave("RPP_F1_VQPpv.eps",plot=g.pv1)
# VQP PANEL B: effect size -------------------------------------------------
# Get effect size quantiles and frequencies from data
qtiles <- ldply(unique(df$grpN),function(gr) quantile(df$EffectSize[df$grpN==gr],probs,na.rm=T,type=3,include.lowest=T))
freqs <- ldply(unique(df$grpN),function(gr) table(cut(df$EffectSize[df$grpN==gr],breaks=qtiles[gr,],na.rm=T,include.lowest=T)))
labels <- sapply(unique(df$grpN),function(gr)levels(cut(round(df$EffectSize[df$grpN==gr],digits=4), breaks = qtiles[gr,],na.rm=T,include.lowest=T,right=T)))
# Check the Quantile bins!
ori <-cbind(freq=as.numeric(t(freqs[1,])))
rownames(ori) <- labels[,1]
ori
rep <-cbind(freq=as.numeric(t(freqs[2,])))
rownames(rep) <- labels[,2]
rep
# Get regular violinplot using package ggplot2
g.es <- ggplot(df,aes(x=grp,y=EffectSize)) + geom_violin(aes(group=grpN),scale="width",fill="grey40",color="grey40",trim=T,adjust=1)
# Cut at quantiles using vioQtile() in C-3PR
g.es0 <- vioQtile(g.es,qtiles=qtiles,probs=probs)
# Garnish
g.es1 <- g.es0 +
ggtitle("B") + xlab("") + ylab("Effect Size") +
scale_y_continuous(breaks=c(-.25,-.5,0,.25,.5,.75,1),limits=c(-.5,1)) + mytheme + theme(legend.position=c(.25,.165), legend.text=element_text(size=20), legend.title=element_text(size=22), axis.text.x=element_text(size=26), axis.text.y=element_text(size=22), axis.title.y=element_text(size=30, vjust=2.6), title=element_text(size=27))
# View
g.es1
# # Uncomment to save panel B as a seperate file
# ggsave("RPP_F1_VQPes.eps",plot=g.es1)
# VIEW panels in one plot using the multi.PLOT() function from C-3PR
multi.PLOT(g.pv1,g.es1,cols=2)
13 References
Briscoe, M. H. (1996). Preparing scientific illustrations. Springer.
Open Science Collaboration (2015). Estimating the reproducibility of psychological science. Science, 349, 943.
Schweinsberg, M., Madan, N., Vianello, M., Sommer, S. A., Jordan, J., Tierney, W., Awtrey, E., Zhu, L., Diermeier, D., Heinze, J., Srinivasan, M., Tannenbaum, D., Bivolaru, E., Dana, J., Davis-Stober, C. P., Du Plessis, C. Gronau, Q. F., Hafenbrack, A. C., Liao, E. Y., Ly, A., Marsman, M., Murase, T., Qureshi, I., Schaerer, M., Thornley, N., Tworek, C. M., Wagenmakers, E-J., Wong, L., Anderson, T., Bauman, C. W., Bedwell, W. L., Brescoll, V., Canavan, A., Chandler, J. J., Cheries, E., Cheryan, S., Cheung, F., Cimpian, A., Clark, M., Cordon, D., Cushman, F., Ditto, P. H., Donahue, T., Frick, S. E., Gamez-Djokic, M., Hofstein Grady, R., Graham, J., Gu, J., Hahn, A., Hanson, B. E., Hartwich, N. J., Hein, K., Inbar, Y., Jiang, L., Kellogg, T., Kennedy, D. M., Legate, N., Luoma, T. P., Maibeucher, H., Meindl, P., Miles, J., Mislin, A., Molden, D. C., Motyl, M., Newman, G., Ngo, H. H., Packham, H., Ramsay, P. S., Ray, J. L., Sackett, A. M., Sellier, A-L., Sokolova, T., Sowden, W., Storage, D., Sun, X., Van Bavel, J. J., Washburn, A. N., Wei, C., Wetter, E., Wilson, C., Darroux, S-C., & Uhlmann, E. L. (in press). The pipeline project: Pre-publication independent replications of a single laboratory’s research pipeline. Journal of Experimental Social Psychology.
Verhagen, A. J., & Wagenmakers, E.-J. (2014). Bayesian tests to quantify the result of a replication attempt. Journal of Experimental Psychology: General, 143, 1457-1475.